X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2Frename%2FRnExpr.lhs;h=23e41c0e9fcebac8c9ad6cb1fabf24174b4d86df;hb=98232a6130f0661486899530fa3461e32499366f;hp=36bbc4bfde53799189a33cf2cd6b4ab242f2d7c9;hpb=10539b475d8584e58bb2c6db928e102ee63e5af5;p=ghc-hetmet.git diff --git a/ghc/compiler/rename/RnExpr.lhs b/ghc/compiler/rename/RnExpr.lhs index 36bbc4b..23e41c0 100644 --- a/ghc/compiler/rename/RnExpr.lhs +++ b/ghc/compiler/rename/RnExpr.lhs @@ -28,8 +28,9 @@ import RdrHsSyn import RnHsSyn import TcRnMonad import RnEnv +import RnNames ( importsFromLocalDecls ) import RnTypes ( rnHsTypeFVs, rnPat, litFVs, rnOverLit, rnPatsAndThen, - dupFieldErr, precParseErr, sectionPrecErr, patSigErr ) + dupFieldErr, precParseErr, sectionPrecErr, patSigErr, checkTupSize ) import CmdLineOpts ( DynFlag(..), opt_IgnoreAsserts ) import BasicTypes ( Fixity(..), FixityDirection(..), IPName(..), defaultFixity, negateFixity, compareFixity ) @@ -37,21 +38,22 @@ import PrelNames ( hasKey, assertIdKey, foldrName, buildName, cCallableClassName, cReturnableClassName, enumClassName, + loopAName, choiceAName, appAName, arrAName, composeAName, firstAName, splitName, fstName, sndName, ioDataConName, replicatePName, mapPName, filterPName, crossPName, zipPName, toPName, enumFromToPName, enumFromThenToPName, assertErrorName, - negateName, qTyConName, monadNames, mfixName ) -import RdrName ( RdrName ) + negateName, monadNames, mfixName ) import Name ( Name, nameOccName ) import NameSet import UnicodeUtil ( stringToUtf8 ) import UniqFM ( isNullUFM ) import UniqSet ( emptyUniqSet ) -import Util ( isSingleton ) +import Util ( isSingleton, mapAndUnzip ) import List ( intersectBy, unzip4 ) import ListSetOps ( removeDups ) import Outputable +import SrcLoc ( noSrcLoc ) import FastString \end{code} @@ -69,7 +71,7 @@ rnMatch ctxt match@(Match pats maybe_rhs_sig grhss) = addSrcLoc (getMatchLoc match) $ -- Deal with the rhs type signature - bindPatSigTyVars rhs_sig_tys $ + bindPatSigTyVarsFV rhs_sig_tys $ doptM Opt_GlasgowExts `thenM` \ opt_GlasgowExts -> (case maybe_rhs_sig of Nothing -> returnM (Nothing, emptyFVs) @@ -84,7 +86,7 @@ rnMatch ctxt match@(Match pats maybe_rhs_sig grhss) rnGRHSs ctxt grhss `thenM` \ (grhss', grhss_fvs) -> returnM (Match pats' maybe_rhs_sig' grhss', grhss_fvs `plusFV` ty_fvs) - -- The bindPatSigTyVars and rnPatsAndThen will remove the bound FVs + -- The bindPatSigTyVarsFV and rnPatsAndThen will remove the bound FVs where rhs_sig_tys = case maybe_rhs_sig of Nothing -> [] @@ -160,7 +162,9 @@ rnExpr (HsVar v) = lookupOccRn v `thenM` \ name -> if name `hasKey` assertIdKey && not opt_IgnoreAsserts then -- We expand it to (GHC.Err.assertError location_string) - mkAssertErrorExpr + mkAssertErrorExpr `thenM` \ (e, fvs) -> + returnM (e, fvs `addOneFV` name) + -- Keep 'assert' as a free var, to ensure it's not reported as unused! else -- The normal case. Even if the Id was 'assert', if we are -- ignoring assertions we leave it as GHC.Base.assert; @@ -224,19 +228,26 @@ rnExpr (HsPar e) returnM (HsPar e', fvs_e) -- Template Haskell extensions -rnExpr (HsBracket br_body) - = checkGHCI (thErr "bracket") `thenM_` - rnBracket br_body `thenM` \ (body', fvs_e) -> - returnM (HsBracket body', fvs_e `addOneFV` qTyConName) - -- We use the Q tycon as a proxy to haul in all the smart - -- constructors; see the hack in RnIfaces - -rnExpr (HsSplice n e) - = checkGHCI (thErr "splice") `thenM_` - getSrcLocM `thenM` \ loc -> - newLocalsRn [(n,loc)] `thenM` \ [n'] -> - rnExpr e `thenM` \ (e', fvs_e) -> - returnM (HsSplice n' e', fvs_e) +-- Don't ifdef-GHCI them because we want to fail gracefully +-- (not with an rnExpr crash) in a stage-1 compiler. +rnExpr e@(HsBracket br_body loc) + = addSrcLoc loc $ + checkTH e "bracket" `thenM_` + rnBracket br_body `thenM` \ (body', fvs_e) -> + returnM (HsBracket body' loc, fvs_e `plusFV` thProxyName) + +rnExpr e@(HsSplice n splice loc) + = addSrcLoc loc $ + checkTH e "splice" `thenM_` + newLocalsRn [(n,loc)] `thenM` \ [n'] -> + rnExpr splice `thenM` \ (splice', fvs_e) -> + returnM (HsSplice n' splice' loc, fvs_e `plusFV` thProxyName) + +rnExpr e@(HsReify (Reify flavour name)) + = checkTH e "reify" `thenM_` + lookupGlobalOccRn name `thenM` \ name' -> + -- For now, we can only reify top-level things + returnM (HsReify (Reify flavour name'), unitFV name' `plusFV` thProxyName) rnExpr section@(SectionL expr op) = rnExpr expr `thenM` \ (expr', fvs_expr) -> @@ -258,6 +269,10 @@ rnExpr (HsCCall fun args may_gc is_casm _) cReturnableClassName, ioDataConName]) +rnExpr (HsCoreAnn ann expr) + = rnExpr expr `thenM` \ (expr', fvs_expr) -> + returnM (HsCoreAnn ann expr', fvs_expr) + rnExpr (HsSCC lbl expr) = rnExpr expr `thenM` \ (expr', fvs_expr) -> returnM (HsSCC lbl expr', fvs_expr) @@ -273,12 +288,6 @@ rnExpr (HsLet binds expr) rnExpr expr `thenM` \ (expr',fvExpr) -> returnM (HsLet binds' expr', fvExpr) -rnExpr (HsWith expr binds is_with) - = warnIf is_with withWarning `thenM_` - rnExpr expr `thenM` \ (expr',fvExpr) -> - rnIPBinds binds `thenM` \ (binds',fvBinds) -> - returnM (HsWith expr' binds' is_with, fvExpr `plusFV` fvBinds) - rnExpr e@(HsDo do_or_lc stmts _ _ src_loc) = addSrcLoc src_loc $ rnStmts do_or_lc stmts `thenM` \ (stmts', fvs) -> @@ -290,20 +299,20 @@ rnExpr e@(HsDo do_or_lc stmts _ _ src_loc) } `thenM_` -- Generate the rebindable syntax for the monad - mapAndUnzipM lookupSyntaxName - (syntax_names do_or_lc) `thenM` \ (monad_names', monad_fvs) -> + lookupSyntaxNames syntax_names `thenM` \ (syntax_names', monad_fvs) -> - returnM (HsDo do_or_lc stmts' monad_names' placeHolderType src_loc, - fvs `plusFV` implicit_fvs do_or_lc `plusFV` plusFVs monad_fvs) + returnM (HsDo do_or_lc stmts' syntax_names' placeHolderType src_loc, + fvs `plusFV` implicit_fvs do_or_lc `plusFV` monad_fvs) where implicit_fvs PArrComp = mkFVs [replicatePName, mapPName, filterPName, crossPName, zipPName] implicit_fvs ListComp = mkFVs [foldrName, buildName] implicit_fvs DoExpr = emptyFVs implicit_fvs MDoExpr = emptyFVs - syntax_names DoExpr = monadNames - syntax_names MDoExpr = monadNames ++ [mfixName] - syntax_names other = [] + syntax_names = case do_or_lc of + DoExpr -> monadNames + MDoExpr -> monadNames ++ [mfixName] + other -> [] rnExpr (ExplicitList _ exps) = rnExprs exps `thenM` \ (exps', fvs) -> @@ -314,11 +323,13 @@ rnExpr (ExplicitPArr _ exps) returnM (ExplicitPArr placeHolderType exps', fvs `addOneFV` toPName `addOneFV` parrTyCon_name) -rnExpr (ExplicitTuple exps boxity) - = rnExprs exps `thenM` \ (exps', fvs) -> +rnExpr e@(ExplicitTuple exps boxity) + = checkTupSize tup_size `thenM_` + rnExprs exps `thenM` \ (exps', fvs) -> returnM (ExplicitTuple exps' boxity, fvs `addOneFV` tycon_name) where - tycon_name = tupleTyCon_name boxity (length exps) + tup_size = length exps + tycon_name = tupleTyCon_name boxity tup_size rnExpr (RecordCon con_id rbinds) = lookupOccRn con_id `thenM` \ conname -> @@ -377,6 +388,216 @@ rnExpr e@(ELazyPat _) = addErr (patSynErr e) `thenM_` %************************************************************************ %* * + Arrow notation +%* * +%************************************************************************ + +\begin{code} +rnExpr (HsProc pat body src_loc) + = addSrcLoc src_loc $ + rnPatsAndThen ProcExpr [pat] $ \ [pat'] -> + rnCmdTop body `thenM` \ (body',fvBody) -> + returnM (HsProc pat' body' src_loc, fvBody) + +rnExpr (HsArrApp arrow arg _ ho rtl srcloc) + = rnExpr arrow `thenM` \ (arrow',fvArrow) -> + rnExpr arg `thenM` \ (arg',fvArg) -> + returnM (HsArrApp arrow' arg' placeHolderType ho rtl srcloc, + fvArrow `plusFV` fvArg) + +-- infix form +rnExpr (HsArrForm op (Just _) [arg1, arg2] srcloc) + = rnExpr op `thenM` \ (op'@(HsVar op_name),fv_op) -> + rnCmdTop arg1 `thenM` \ (arg1',fv_arg1) -> + rnCmdTop arg2 `thenM` \ (arg2',fv_arg2) -> + + -- Deal with fixity + + lookupFixityRn op_name `thenM` \ fixity -> + mkOpFormRn arg1' op' fixity arg2' `thenM` \ final_e -> + + returnM (final_e, + fv_arg1 `plusFV` fv_op `plusFV` fv_arg2) + +rnExpr (HsArrForm op fixity cmds srcloc) + = rnExpr op `thenM` \ (op',fvOp) -> + rnCmdArgs cmds `thenM` \ (cmds',fvCmds) -> + returnM (HsArrForm op' fixity cmds' srcloc, + fvOp `plusFV` fvCmds) + +--------------------------- +-- Deal with fixity (cf mkOpAppRn for the method) + +mkOpFormRn :: RenamedHsCmdTop -- Left operand; already rearranged + -> RenamedHsExpr -> Fixity -- Operator and fixity + -> RenamedHsCmdTop -- Right operand (not an infix) + -> RnM RenamedHsCmd + +--------------------------- +-- (e11 `op1` e12) `op2` e2 +mkOpFormRn a1@(HsCmdTop (HsArrForm op1 (Just fix1) [a11,a12] loc1) _ _ _) op2 fix2 a2 + | nofix_error + = addErr (precParseErr (ppr_op op1,fix1) (ppr_op op2,fix2)) `thenM_` + returnM (HsArrForm op2 (Just fix2) [a1, a2] loc1) + + | associate_right + = mkOpFormRn a12 op2 fix2 a2 `thenM` \ new_c -> + returnM (HsArrForm op1 (Just fix1) + [a11, HsCmdTop new_c [] placeHolderType []] loc1) + 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] noSrcLoc) + +\end{code} + + +%************************************************************************ +%* * + Arrow commands +%* * +%************************************************************************ + +\begin{code} +rnCmdArgs [] = returnM ([], emptyFVs) +rnCmdArgs (arg:args) + = rnCmdTop arg `thenM` \ (arg',fvArg) -> + rnCmdArgs args `thenM` \ (args',fvArgs) -> + returnM (arg':args', fvArg `plusFV` fvArgs) + +rnCmdTop (HsCmdTop cmd _ _ _) + = rnExpr (convertOpFormsCmd cmd) `thenM` \ (cmd', fvCmd) -> + let + cmd_names = [arrAName, composeAName, firstAName] ++ + nameSetToList (methodNamesCmd cmd') + in + -- Generate the rebindable syntax for the monad + lookupSyntaxNames cmd_names `thenM` \ (cmd_names', cmd_fvs) -> + + returnM (HsCmdTop cmd' [] placeHolderType cmd_names', + fvCmd `plusFV` cmd_fvs) + +--------------------------------------------------- +-- convert OpApp's in a command context to HsArrForm's + +convertOpFormsCmd :: HsCmd id -> HsCmd id + +convertOpFormsCmd (HsApp c e) = HsApp (convertOpFormsCmd c) e + +convertOpFormsCmd (HsLam match) = HsLam (convertOpFormsMatch match) + +convertOpFormsCmd (OpApp c1 op fixity c2) + = let + arg1 = HsCmdTop (convertOpFormsCmd c1) [] placeHolderType [] + arg2 = HsCmdTop (convertOpFormsCmd c2) [] placeHolderType [] + in + HsArrForm op (Just fixity) [arg1, arg2] noSrcLoc + +convertOpFormsCmd (HsPar c) = HsPar (convertOpFormsCmd c) + +convertOpFormsCmd (HsCase exp matches locn) + = HsCase exp (map convertOpFormsMatch matches) locn + +convertOpFormsCmd (HsIf exp c1 c2 locn) + = HsIf exp (convertOpFormsCmd c1) (convertOpFormsCmd c2) locn + +convertOpFormsCmd (HsLet binds cmd) + = HsLet binds (convertOpFormsCmd cmd) + +convertOpFormsCmd (HsDo ctxt stmts ids ty locn) + = HsDo ctxt (map convertOpFormsStmt stmts) ids ty locn + +-- Anything else is unchanged. This includes HsArrForm (already done), +-- things with no sub-commands, and illegal commands (which will be +-- caught by the type checker) +convertOpFormsCmd c = c + +convertOpFormsStmt (BindStmt pat cmd locn) + = BindStmt pat (convertOpFormsCmd cmd) locn +convertOpFormsStmt (ResultStmt cmd locn) + = ResultStmt (convertOpFormsCmd cmd) locn +convertOpFormsStmt (ExprStmt cmd ty locn) + = ExprStmt (convertOpFormsCmd cmd) ty locn +convertOpFormsStmt (RecStmt stmts lvs rvs es) + = RecStmt (map convertOpFormsStmt stmts) lvs rvs es +convertOpFormsStmt stmt = stmt + +convertOpFormsMatch (Match pat mty grhss) + = Match pat mty (convertOpFormsGRHSs grhss) + +convertOpFormsGRHSs (GRHSs grhss binds ty) + = GRHSs (map convertOpFormsGRHS grhss) binds ty + +convertOpFormsGRHS (GRHS stmts locn) + = let + (ResultStmt cmd locn') = last stmts + in + GRHS (init stmts ++ [ResultStmt (convertOpFormsCmd cmd) locn']) locn + +--------------------------------------------------- +type CmdNeeds = FreeVars -- Only inhabitants are + -- appAName, choiceAName, loopAName + +-- find what methods the Cmd needs (loop, choice, apply) +methodNamesCmd :: HsCmd Name -> CmdNeeds + +methodNamesCmd cmd@(HsArrApp _arrow _arg _ HsFirstOrderApp _rtl _srcloc) + = emptyFVs +methodNamesCmd cmd@(HsArrApp _arrow _arg _ HsHigherOrderApp _rtl _srcloc) + = unitFV appAName +methodNamesCmd cmd@(HsArrForm {}) = emptyFVs + +methodNamesCmd (HsPar c) = methodNamesCmd c + +methodNamesCmd (HsIf p c1 c2 loc) + = methodNamesCmd c1 `plusFV` methodNamesCmd c2 `addOneFV` choiceAName + +methodNamesCmd (HsLet b c) = methodNamesCmd c + +methodNamesCmd (HsDo sc stmts rbs ty loc) = methodNamesStmts stmts + +methodNamesCmd (HsApp c e) = methodNamesCmd c + +methodNamesCmd (HsLam match) = methodNamesMatch match + +methodNamesCmd (HsCase scrut matches loc) + = plusFVs (map methodNamesMatch matches) `addOneFV` choiceAName + +methodNamesCmd other = emptyFVs + -- Other forms can't occur in commands, but it's not convenient + -- to error here so we just do what's convenient. + -- The type checker will complain later + +--------------------------------------------------- +methodNamesMatch (Match pats sig_ty grhss) = methodNamesGRHSs grhss + +------------------------------------------------- +methodNamesGRHSs (GRHSs grhss binds ty) = plusFVs (map methodNamesGRHS grhss) + +------------------------------------------------- +methodNamesGRHS (GRHS stmts loc) = methodNamesStmt (last stmts) + +--------------------------------------------------- +methodNamesStmts stmts = plusFVs (map methodNamesStmt stmts) + +--------------------------------------------------- +methodNamesStmt (ResultStmt cmd loc) = methodNamesCmd cmd +methodNamesStmt (ExprStmt cmd ty loc) = methodNamesCmd cmd +methodNamesStmt (BindStmt pat cmd loc) = methodNamesCmd cmd +methodNamesStmt (RecStmt stmts lvs rvs es) + = methodNamesStmts stmts `addOneFV` loopAName +methodNamesStmt (LetStmt b) = emptyFVs +methodNamesStmt (ParStmt ss) = emptyFVs + -- ParStmt can't occur in commands, but it's not convenient to error + -- here so we just do what's convenient +\end{code} + + +%************************************************************************ +%* * Arithmetic sequences %* * %************************************************************************ @@ -429,22 +650,6 @@ rnRbinds str rbinds %************************************************************************ %* * -\subsubsection{@rnIPBinds@s: in implicit parameter bindings} * -%* * -%************************************************************************ - -\begin{code} -rnIPBinds [] = returnM ([], emptyFVs) -rnIPBinds ((n, expr) : binds) - = newIPName n `thenM` \ name -> - rnExpr expr `thenM` \ (expr',fvExpr) -> - rnIPBinds binds `thenM` \ (binds',fvBinds) -> - returnM ((name, expr') : binds', fvExpr `plusFV` fvBinds) - -\end{code} - -%************************************************************************ -%* * Template Haskell brackets %* * %************************************************************************ @@ -458,10 +663,16 @@ rnBracket (TypBr t) = rnHsTypeFVs doc t `thenM` \ (t', fvs) -> returnM (TypBr t', fvs) where doc = ptext SLIT("In a Template-Haskell quoted type") -rnBracket (DecBr ds) = rnSrcDecls ds `thenM` \ (tcg_env, ds', fvs) -> - -- Discard the tcg_env; it contains the extended global RdrEnv - -- because there is no scope that these decls cover (yet!) - returnM (DecBr ds', fvs) +rnBracket (DecBr group) + = importsFromLocalDecls group `thenM` \ (rdr_env, avails) -> + -- Discard avails (not useful here) + + updGblEnv (\gbl -> gbl { tcg_rdr_env = rdr_env `plusGlobalRdrEnv` tcg_rdr_env gbl }) $ + + rnSrcDecls group `thenM` \ (tcg_env, group', dus) -> + -- Discard the tcg_env; it contains only extra info about fixity + + returnM (DecBr group', duUses dus `minusNameSet` duDefs dus) \end{code} %************************************************************************ @@ -507,66 +718,93 @@ rnNormalStmts ctxt (BindStmt pat expr src_loc : stmts) -- the rnPatsAndThen, but it does not matter rnNormalStmts ctxt (LetStmt binds : stmts) - = rnBindsAndThen binds $ \ binds' -> - rnNormalStmts ctxt stmts `thenM` \ (stmts', fvs) -> - returnM (LetStmt binds' : stmts', fvs) + = checkErr (ok ctxt binds) (badIpBinds binds) `thenM_` + rnBindsAndThen binds ( \ binds' -> + rnNormalStmts ctxt stmts `thenM` \ (stmts', fvs) -> + returnM (LetStmt binds' : stmts', fvs)) + where + -- We do not allow implicit-parameter bindings in a parallel + -- list comprehension. I'm not sure what it might mean. + ok (ParStmtCtxt _) (IPBinds _ _) = False + ok _ _ = True rnNormalStmts ctxt (ParStmt stmtss : stmts) - = mapFvRn (rnNormalStmts ctxt) stmtss `thenM` \ (stmtss', fv_stmtss) -> + = doptM Opt_GlasgowExts `thenM` \ opt_GlasgowExts -> + checkM opt_GlasgowExts parStmtErr `thenM_` + mapFvRn rn_branch stmtss `thenM` \ (stmtss', fv_stmtss) -> let - bndrss = map collectStmtsBinders stmtss' + bndrss :: [[Name]] -- NB: Name, not RdrName + bndrss = map collectStmtsBinders stmtss' + (bndrs, dups) = removeDups cmpByOcc (concat bndrss) in - foldlM checkBndrs [] bndrss `thenM` \ new_binders -> - bindLocalNamesFV new_binders $ + mappM dupErr dups `thenM` \ _ -> + bindLocalNamesFV bndrs $ -- Note: binders are returned in scope order, so one may -- shadow the next; e.g. x <- xs; x <- ys rnNormalStmts ctxt stmts `thenM` \ (stmts', fvs) -> - returnM (ParStmtOut (bndrss `zip` stmtss') : stmts', + + -- Cut down the exported binders to just the ones neede in the body + let + used_bndrs_s = map (filter (`elemNameSet` fvs)) bndrss + in + returnM (ParStmt (stmtss' `zip` used_bndrs_s) : stmts', fv_stmtss `plusFV` fvs) where - checkBndrs all_bndrs bndrs - = checkErr (null common) (err (head common)) `thenM_` - returnM (bndrs ++ all_bndrs) - where - common = intersectBy eqOcc all_bndrs bndrs + rn_branch (stmts, _) = rnNormalStmts (ParStmtCtxt ctxt) stmts - eqOcc n1 n2 = nameOccName n1 == nameOccName n2 - err v = ptext SLIT("Duplicate binding in parallel list comprehension for:") - <+> quotes (ppr v) + cmpByOcc n1 n2 = nameOccName n1 `compare` nameOccName n2 + dupErr (v:_) = addErr (ptext SLIT("Duplicate binding in parallel list comprehension for:") + <+> quotes (ppr v)) -rnNormalStmts ctxt stmts = pprPanic "rnNormalStmts" (ppr stmts) +rnNormalStmts ctxt (RecStmt rec_stmts _ _ _ : stmts) + = bindLocalsRn doc (collectStmtsBinders rec_stmts) $ \ _ -> + rn_rec_stmts rec_stmts `thenM` \ segs -> + rnNormalStmts ctxt stmts `thenM` \ (stmts', fvs) -> + let + segs_w_fwd_refs = addFwdRefs segs + (ds, us, fs, rec_stmts') = unzip4 segs_w_fwd_refs + later_vars = nameSetToList (plusFVs ds `intersectNameSet` fvs) + fwd_vars = nameSetToList (plusFVs fs) + uses = plusFVs us + in + returnM (RecStmt rec_stmts' later_vars fwd_vars [] : stmts', uses `plusFV` fvs) + where + doc = text "In a recursive do statement" \end{code} %************************************************************************ %* * -\subsubsection{Precedence Parsing} +\subsubsection{mdo expressions} %* * %************************************************************************ \begin{code} -type Defs = NameSet -type Uses = NameSet -- Same as FreeVars really type FwdRefs = NameSet -type Segment = (Defs, - Uses, -- May include defs - FwdRefs, -- A subset of uses that are +type Segment stmts = (Defs, + Uses, -- May include defs + FwdRefs, -- A subset of uses that are -- (a) used before they are bound in this segment, or -- (b) used here, and bound in subsequent segments - [RenamedStmt]) + stmts) -- Either Stmt or [Stmt] + ---------------------------------------------------- rnMDoStmts :: [RdrNameStmt] -> RnM ([RenamedStmt], FreeVars) rnMDoStmts stmts = -- Step1: bring all the binders of the mdo into scope + -- Remember that this also removes the binders from the + -- finally-returned free-vars bindLocalsRn doc (collectStmtsBinders stmts) $ \ _ -> -- Step 2: Rename each individual stmt, making a -- singleton segment. At this stage the FwdRefs field -- isn't finished: it's empty for all except a BindStmt -- for which it's the fwd refs within the bind itself - mappM rn_mdo_stmt stmts `thenM` \ segs -> + -- (This set may not be empty, because we're in a recursive + -- context.) + rn_rec_stmts stmts `thenM` \ segs -> let -- Step 3: Fill in the fwd refs. -- The segments are all singletons, but their fwd-ref @@ -590,22 +828,24 @@ rnMDoStmts stmts where doc = text "In a mdo-expression" + ---------------------------------------------------- -rn_mdo_stmt :: RdrNameStmt -> RnM Segment +rn_rec_stmt :: RdrNameStmt -> RnM [Segment RenamedStmt] + -- 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_mdo_stmt (ExprStmt expr _ src_loc) +rn_rec_stmt (ExprStmt expr _ src_loc) = addSrcLoc src_loc (rnExpr expr) `thenM` \ (expr', fvs) -> - returnM (emptyNameSet, fvs, emptyNameSet, - [ExprStmt expr' placeHolderType src_loc]) + returnM [(emptyNameSet, fvs, emptyNameSet, + ExprStmt expr' placeHolderType src_loc)] -rn_mdo_stmt (ResultStmt expr src_loc) +rn_rec_stmt (ResultStmt expr src_loc) = addSrcLoc src_loc (rnExpr expr) `thenM` \ (expr', fvs) -> - returnM (emptyNameSet, fvs, emptyNameSet, - [ResultStmt expr' src_loc]) + returnM [(emptyNameSet, fvs, emptyNameSet, + ResultStmt expr' src_loc)] -rn_mdo_stmt (BindStmt pat expr src_loc) +rn_rec_stmt (BindStmt pat expr src_loc) = addSrcLoc src_loc $ rnExpr expr `thenM` \ (expr', fv_expr) -> rnPat pat `thenM` \ (pat', fv_pat) -> @@ -613,19 +853,28 @@ rn_mdo_stmt (BindStmt pat expr src_loc) bndrs = mkNameSet (collectPatBinders pat') fvs = fv_expr `plusFV` fv_pat in - returnM (bndrs, fvs, bndrs `intersectNameSet` fvs, - [BindStmt pat' expr' src_loc]) + returnM [(bndrs, fvs, bndrs `intersectNameSet` fvs, + BindStmt pat' expr' src_loc)] + +rn_rec_stmt (LetStmt binds) + = rnBinds binds `thenM` \ (binds', du_binds) -> + returnM [(duDefs du_binds, duUses du_binds, + emptyNameSet, LetStmt binds')] + +rn_rec_stmt (RecStmt stmts _ _ _) -- Flatten Rec inside Rec + = rn_rec_stmts stmts -rn_mdo_stmt (LetStmt binds) - = rnBinds binds `thenM` \ (binds', fv_binds) -> - returnM (mkNameSet (collectHsBinders binds'), - fv_binds, emptyNameSet, [LetStmt binds']) +rn_rec_stmt stmt@(ParStmt _) -- Syntactically illegal in mdo + = pprPanic "rn_rec_stmt" (ppr stmt) -rn_mdo_stmt stmt@(ParStmt _) -- Syntactically illegal in mdo - = pprPanic "rn_mdo_stmt" (ppr stmt) +--------------------------------------------- +rn_rec_stmts :: [RdrNameStmt] -> RnM [Segment RenamedStmt] +rn_rec_stmts stmts = mappM rn_rec_stmt stmts `thenM` \ segs_s -> + returnM (concat segs_s) -addFwdRefs :: [Segment] -> [Segment] +--------------------------------------------- +addFwdRefs :: [Segment a] -> [Segment a] -- So far the segments only have forward refs *within* the Stmt -- (which happens for bind: x <- ...x...) -- This function adds the cross-seg fwd ref info @@ -633,12 +882,12 @@ addFwdRefs :: [Segment] -> [Segment] addFwdRefs pairs = fst (foldr mk_seg ([], emptyNameSet) pairs) where - mk_seg (defs, uses, fwds, stmts) (segs, seg_defs) + mk_seg (defs, uses, fwds, stmts) (segs, later_defs) = (new_seg : segs, all_defs) where new_seg = (defs, uses, new_fwds, stmts) - all_defs = seg_defs `unionNameSets` defs - new_fwds = fwds `unionNameSets` (uses `intersectNameSet` seg_defs) + all_defs = later_defs `unionNameSets` defs + new_fwds = fwds `unionNameSets` (uses `intersectNameSet` later_defs) -- Add the downstream fwd refs here ---------------------------------------------------- @@ -676,10 +925,10 @@ addFwdRefs pairs -- q <- x ; z <- y } ; -- r <- x } -glomSegments :: [Segment] -> [Segment] +glomSegments :: [Segment RenamedStmt] -> [Segment [RenamedStmt]] -glomSegments [seg] = [seg] -glomSegments ((defs,uses,fwds,stmts) : segs) +glomSegments [] = [] +glomSegments ((defs,uses,fwds,stmt) : segs) -- Actually stmts will always be a singleton = (seg_defs, seg_uses, seg_fwds, seg_stmts) : others where @@ -690,12 +939,12 @@ glomSegments ((defs,uses,fwds,stmts) : segs) seg_defs = plusFVs ds `plusFV` defs seg_uses = plusFVs us `plusFV` uses seg_fwds = plusFVs fs `plusFV` fwds - seg_stmts = stmts ++ concat ss + seg_stmts = stmt : concat ss grab :: NameSet -- The client - -> [Segment] - -> ([Segment], -- Needed by the 'client' - [Segment]) -- Not needed by the client + -> [Segment a] + -> ([Segment a], -- Needed by the 'client' + [Segment a]) -- Not needed by the client -- The result is simply a split of the input grab uses dus = (reverse yeses, reverse noes) @@ -705,7 +954,7 @@ glomSegments ((defs,uses,fwds,stmts) : segs) ---------------------------------------------------- -segsToStmts :: [Segment] -> ([RenamedStmt], FreeVars) +segsToStmts :: [Segment [RenamedStmt]] -> ([RenamedStmt], FreeVars) segsToStmts [] = ([], emptyFVs) segsToStmts ((defs, uses, fwds, ss) : segs) @@ -713,13 +962,11 @@ segsToStmts ((defs, uses, fwds, ss) : segs) where (later_stmts, later_uses) = segsToStmts segs new_stmt | non_rec = head ss - | otherwise = RecStmt rec_names ss + | otherwise = RecStmt ss (nameSetToList used_later) (nameSetToList fwds) [] where - non_rec = isSingleton ss && isEmptyNameSet fwds - rec_names = nameSetToList (fwds `plusFV` (defs `intersectNameSet` later_uses)) - -- The names for the fixpoint are - -- (a) the ones needed after the RecStmt - -- (b) the forward refs within the fixpoint + non_rec = isSingleton ss && isEmptyNameSet fwds + used_later = defs `intersectNameSet` later_uses + -- The ones needed after the RecStmt \end{code} %************************************************************************ @@ -911,14 +1158,18 @@ doStmtListErr do_or_lc e MDoExpr -> "mdo" other -> "do" -thErr what - = ptext SLIT("Template Haskell") <+> text what <+> - ptext SLIT("illegal in a stage-1 compiler") +#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 -fglagow-exts")) -withWarning - = sep [quotes (ptext SLIT("with")), - ptext SLIT("is deprecated, use"), - quotes (ptext SLIT("let")), - ptext SLIT("instead")] +badIpBinds binds + = hang (ptext SLIT("Implicit-parameter bindings illegal in a parallel list comprehension:")) 4 + (ppr binds) \end{code}