X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2Frename%2FRnExpr.lhs;h=cda67c42554c7ed853c579797ebe257ffe5a2561;hb=10fcd78ccde892feccda3f5eacd221c1de75feea;hp=dba30bde4370036a3940c5eec3e51fd89669017b;hpb=2c2509997743edeb63830b86c8ee910db2414c6b;p=ghc-hetmet.git diff --git a/ghc/compiler/rename/RnExpr.lhs b/ghc/compiler/rename/RnExpr.lhs index dba30bd..cda67c4 100644 --- a/ghc/compiler/rename/RnExpr.lhs +++ b/ghc/compiler/rename/RnExpr.lhs @@ -28,22 +28,25 @@ import RnTypes ( rnHsTypeFVs ) import RnHiFiles ( lookupFixityRn ) import CmdLineOpts ( DynFlag(..), opt_IgnoreAsserts ) import Literal ( inIntRange, inCharRange ) -import BasicTypes ( Fixity(..), FixityDirection(..), defaultFixity, negateFixity ) +import BasicTypes ( Fixity(..), FixityDirection(..), IPName(..), + 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, assertErr_RDR, - ioDataCon_RDR, plusInteger_RDR, timesInteger_RDR, - ) + eqClassName, foldrName, buildName, eqStringName, + cCallableClassName, cReturnableClassName, + monadClassName, enumClassName, ordClassName, + ratioDataConName, splitName, fstName, sndName, + ioDataConName, plusIntegerName, timesIntegerName, + assertErr_RDR, + replicatePName, mapPName, filterPName, + falseDataConName, trueDataConName, crossPName, + zipPName, lengthPName, indexPName, toPName, + enumFromToPName, enumFromThenToPName ) import TysPrim ( charPrimTyCon, addrPrimTyCon, intPrimTyCon, - floatPrimTyCon, doublePrimTyCon - ) + floatPrimTyCon, doublePrimTyCon ) import TysWiredIn ( intTyCon ) import Name ( NamedThing(..), mkSysLocalName, nameSrcLoc ) import NameSet import UniqFM ( isNullUFM ) -import FiniteMap ( elemFM ) import UniqSet ( emptyUniqSet ) import List ( intersectBy ) import ListSetOps ( removeDups ) @@ -80,8 +83,7 @@ rnPat (SigPatIn pat ty) doc = text "a pattern type-signature" rnPat (LitPatIn s@(HsString _)) - = lookupOrigName eqString_RDR `thenRn` \ eq -> - returnRn (LitPatIn s, unitFV eq) + = returnRn (LitPatIn s, unitFV eqStringName) rnPat (LitPatIn lit) = litFVs lit `thenRn` \ fvs -> @@ -89,15 +91,13 @@ rnPat (LitPatIn lit) 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) + returnRn (NPatIn lit', fvs1 `addOneFV` eqClassName) -- Needed to find equality on pattern rnPat (NPlusKPatIn name lit minus) = rnOverLit lit `thenRn` \ (lit', fvs) -> - lookupOrigName ordClass_RDR `thenRn` \ ord -> lookupBndrRn name `thenRn` \ name' -> lookupSyntaxName minus `thenRn` \ minus' -> - returnRn (NPlusKPatIn name' lit' minus', fvs `addOneFV` ord `addOneFV` minus') + returnRn (NPlusKPatIn name' lit' minus', fvs `addOneFV` ordClassName `addOneFV` minus') rnPat (LazyPatIn pat) = rnPat pat `thenRn` \ (pat', fvs) -> @@ -135,6 +135,13 @@ rnPat (ListPatIn pats) = mapFvRn rnPat pats `thenRn` \ (patslist, fvs) -> returnRn (ListPatIn patslist, fvs `addOneFV` listTyCon_name) +rnPat (PArrPatIn pats) + = mapFvRn rnPat pats `thenRn` \ (patslist, fvs) -> + returnRn (PArrPatIn patslist, + fvs `plusFV` implicit_fvs `addOneFV` parrTyCon_name) + where + implicit_fvs = mkFVs [lengthPName, indexPName] + rnPat (TuplePatIn pats boxed) = mapFvRn rnPat pats `thenRn` \ (patslist, fvs) -> returnRn (TuplePatIn patslist boxed, fvs `addOneFV` tycon_name) @@ -160,7 +167,7 @@ rnPat (TypePatIn name) = \begin{code} rnMatch :: HsMatchContext RdrName -> RdrNameMatch -> RnMS (RenamedMatch, FreeVars) -rnMatch ctxt match@(Match _ pats maybe_rhs_sig grhss) +rnMatch ctxt match@(Match pats maybe_rhs_sig grhss) = pushSrcLocRn (getMatchLoc match) $ -- Bind pattern-bound type variables @@ -172,7 +179,7 @@ rnMatch ctxt match@(Match _ pats maybe_rhs_sig grhss) doc_sig = text "In a result type-signature" doc_pat = pprMatchContext ctxt in - bindPatSigTyVars (rhs_sig_tys ++ pat_sig_tys) $ \ sig_tyvars -> + bindPatSigTyVars (rhs_sig_tys ++ pat_sig_tys) $ -- Note that we do a single bindLocalsRn for all the -- matches together, so that we spot the repeated variable in @@ -197,7 +204,7 @@ rnMatch ctxt match@(Match _ pats maybe_rhs_sig grhss) in warnUnusedMatches unused_binders `thenRn_` - returnRn (Match sig_tyvars pats' maybe_rhs_sig' grhss', all_fvs) + returnRn (Match pats' maybe_rhs_sig' grhss', all_fvs) -- The bindLocals and bindTyVars will remove the bound FVs \end{code} @@ -279,7 +286,12 @@ rnExpr (HsVar v) rnExpr (HsIPVar v) = newIPName v `thenRn` \ name -> - returnRn (HsIPVar name, emptyFVs) + let + fvs = case name of + Linear _ -> mkFVs [splitName, fstName, sndName] + Dupable _ -> emptyFVs + in + returnRn (HsIPVar name, fvs) rnExpr (HsLit lit) = litFVs lit `thenRn` \ fvs -> @@ -342,12 +354,12 @@ rnExpr section@(SectionR op expr) rnExpr (HsCCall fun args may_gc is_casm _) -- Check out the comment on RnIfaces.getNonWiredDataDecl about ccalls - = lookupOrigNames [cCallableClass_RDR, - cReturnableClass_RDR, - ioDataCon_RDR] `thenRn` \ implicit_fvs -> + = lookupOrigNames [] `thenRn` \ implicit_fvs -> rnExprs args `thenRn` \ (args', fvs_args) -> returnRn (HsCCall fun args' may_gc is_casm placeHolderType, - fvs_args `plusFV` implicit_fvs) + fvs_args `plusFV` mkFVs [cCallableClassName, + cReturnableClassName, + ioDataConName]) rnExpr (HsSCC lbl expr) = rnExpr expr `thenRn` \ (expr', fvs_expr) -> @@ -371,7 +383,6 @@ rnExpr (HsWith expr binds) rnExpr e@(HsDo do_or_lc stmts src_loc) = pushSrcLocRn src_loc $ - lookupOrigNames implicit_rdr_names `thenRn` \ implicit_fvs -> rnStmts stmts `thenRn` \ ((_, stmts'), fvs) -> -- check the statement list ends in an expression case last stmts' of { @@ -380,16 +391,24 @@ rnExpr e@(HsDo do_or_lc stmts src_loc) } `thenRn_` returnRn (HsDo do_or_lc stmts' src_loc, fvs `plusFV` implicit_fvs) where - implicit_rdr_names = [foldr_RDR, build_RDR, monadClass_RDR] + implicit_fvs = case do_or_lc of + PArrComp -> mkFVs [replicatePName, mapPName, filterPName, + falseDataConName, trueDataConName, crossPName, + zipPName] + _ -> mkFVs [foldrName, buildName, monadClassName] -- Monad stuff should not be necessary for a list comprehension -- but the typechecker looks up the bind and return Ids anyway -- Oh well. - rnExpr (ExplicitList _ exps) = rnExprs exps `thenRn` \ (exps', fvs) -> returnRn (ExplicitList placeHolderType exps', fvs `addOneFV` listTyCon_name) +rnExpr (ExplicitPArr _ exps) + = rnExprs exps `thenRn` \ (exps', fvs) -> + returnRn (ExplicitPArr placeHolderType exps', + fvs `addOneFV` toPName `addOneFV` parrTyCon_name) + rnExpr (ExplicitTuple exps boxity) = rnExprs exps `thenRn` \ (exps', fvs) -> returnRn (ExplicitTuple exps' boxity, fvs `addOneFV` tycon_name) @@ -425,9 +444,8 @@ rnExpr (HsType a) doc = text "renaming a type pattern" rnExpr (ArithSeqIn seq) - = lookupOrigName enumClass_RDR `thenRn` \ enum -> - rn_seq seq `thenRn` \ (new_seq, fvs) -> - returnRn (ArithSeqIn new_seq, fvs `addOneFV` enum) + = rn_seq seq `thenRn` \ (new_seq, fvs) -> + returnRn (ArithSeqIn new_seq, fvs `addOneFV` enumClassName) where rn_seq (From expr) = rnExpr expr `thenRn` \ (expr', fvExpr) -> @@ -449,6 +467,28 @@ rnExpr (ArithSeqIn seq) rnExpr expr3 `thenRn` \ (expr3', fvExpr3) -> returnRn (FromThenTo expr1' expr2' expr3', plusFVs [fvExpr1, fvExpr2, fvExpr3]) + +rnExpr (PArrSeqIn seq) + = rn_seq seq `thenRn` \ (new_seq, fvs) -> + returnRn (PArrSeqIn new_seq, + fvs `plusFV` mkFVs [enumFromToPName, enumFromThenToPName]) + where + + -- the parser shouldn't generate these two + -- + rn_seq (From _ ) = panic "RnExpr.rnExpr: Infinite parallel array!" + rn_seq (FromThen _ _) = panic "RnExpr.rnExpr: Infinite parallel array!" + + rn_seq (FromTo expr1 expr2) + = rnExpr expr1 `thenRn` \ (expr1', fvExpr1) -> + rnExpr expr2 `thenRn` \ (expr2', fvExpr2) -> + returnRn (FromTo expr1' expr2', fvExpr1 `plusFV` fvExpr2) + rn_seq (FromThenTo expr1 expr2 expr3) + = rnExpr expr1 `thenRn` \ (expr1', fvExpr1) -> + rnExpr expr2 `thenRn` \ (expr2', fvExpr2) -> + rnExpr expr3 `thenRn` \ (expr3', fvExpr3) -> + returnRn (FromThenTo expr1' expr2' expr3', + plusFVs [fvExpr1, fvExpr2, fvExpr3]) \end{code} These three are pattern syntax appearing in expressions. @@ -572,7 +612,7 @@ rnStmt (ParStmt stmtss) thing_inside rnStmt (BindStmt pat expr src_loc) thing_inside = pushSrcLocRn src_loc $ rnExpr expr `thenRn` \ (expr', fv_expr) -> - bindPatSigTyVars (collectSigTysFromPat pat) $ \ sig_tyvars -> + bindPatSigTyVars (collectSigTysFromPat pat) $ bindLocalsFVRn doc (collectPatBinders pat) $ \ new_binders -> rnPat pat `thenRn` \ (pat', fv_pat) -> thing_inside (BindStmt pat' expr' src_loc) `thenRn` \ ((rest_binders, result), fvs) -> @@ -720,7 +760,7 @@ checkPrecMatch :: Bool -> Name -> RenamedMatch -> RnMS () checkPrecMatch False fn match = returnRn () -checkPrecMatch True op (Match _ (p1:p2:_) _ _) +checkPrecMatch True op (Match (p1:p2:_) _ _) -- True indicates an infix lhs = getModeRn `thenRn` \ mode -> -- See comments with rnExpr (OpApp ...) @@ -812,8 +852,7 @@ 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 (HsLitLit l bogus_ty) = returnRn (unitFV cCallableClassName) litFVs lit = pprPanic "RnExpr.litFVs" (ppr lit) -- HsInteger and HsRat only appear -- in post-typechecker translations @@ -821,18 +860,20 @@ rnOverLit (HsIntegral i from_integer_name) = lookupSyntaxName from_integer_name `thenRn` \ from_integer_name' -> if inIntRange i then returnRn (HsIntegral i from_integer_name', unitFV from_integer_name') - else - lookupOrigNames [plusInteger_RDR, timesInteger_RDR] `thenRn` \ ns -> + else let + fvs = mkFVs [plusIntegerName, timesIntegerName] -- Big integer literals are built, using + and *, -- out of small integers (DsUtils.mkIntegerLit) -- [NB: plusInteger, timesInteger aren't rebindable... -- they are used to construct the argument to fromInteger, -- which is the rebindable one.] - returnRn (HsIntegral i from_integer_name', ns `addOneFV` from_integer_name') + in + returnRn (HsIntegral i from_integer_name', fvs `addOneFV` from_integer_name') rnOverLit (HsFractional i from_rat_name) = lookupSyntaxName from_rat_name `thenRn` \ from_rat_name' -> - lookupOrigNames [ratioDataCon_RDR, plusInteger_RDR, timesInteger_RDR] `thenRn` \ ns -> + let + fvs = mkFVs [ratioDataConName, plusIntegerName, timesIntegerName] -- 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. @@ -840,7 +881,8 @@ rnOverLit (HsFractional i from_rat_name) -- when fractionalClass does. -- The plus/times integer operations may be needed to construct the numerator -- and denominator (see DsUtils.mkIntegerLit) - returnRn (HsFractional i from_rat_name', ns `addOneFV` from_rat_name') + in + returnRn (HsFractional i from_rat_name', fvs `addOneFV` from_rat_name') \end{code} %************************************************************************