X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=blobdiff_plain;f=compiler%2FdeSugar%2FDsExpr.lhs;h=2ac19ce5cb97d8bf40031988360495ea5ece7122;hp=5b566a0f80002a2983b0afd236b98b8649f6029f;hb=b2524b3960999fffdb3767900f58825903f6560f;hpb=841e81e28f8cc711f624fdca122219a5bbde2fae diff --git a/compiler/deSugar/DsExpr.lhs b/compiler/deSugar/DsExpr.lhs index 5b566a0..2ac19ce 100644 --- a/compiler/deSugar/DsExpr.lhs +++ b/compiler/deSugar/DsExpr.lhs @@ -49,8 +49,8 @@ import DynFlags import StaticFlags import CostCentre import Id -import Var import VarSet +import VarEnv import DataCon import TysWiredIn import BasicTypes @@ -335,26 +335,12 @@ dsExpr (HsLet binds body) = do -- We need the `ListComp' form to use `deListComp' (rather than the "do" form) -- because the interpretation of `stmts' depends on what sort of thing it is. -- -dsExpr (HsDo ListComp stmts body result_ty) - = -- Special case for list comprehensions - dsListComp stmts body elt_ty - where - [elt_ty] = tcTyConAppArgs result_ty - -dsExpr (HsDo DoExpr stmts body result_ty) - = dsDo stmts body result_ty - -dsExpr (HsDo GhciStmt stmts body result_ty) - = dsDo stmts body result_ty - -dsExpr (HsDo MDoExpr stmts body result_ty) - = dsDo stmts body result_ty - -dsExpr (HsDo PArrComp stmts body result_ty) - = -- Special case for array comprehensions - dsPArrComp (map unLoc stmts) body elt_ty - where - [elt_ty] = tcTyConAppArgs result_ty +dsExpr (HsDo ListComp stmts res_ty) = dsListComp stmts res_ty +dsExpr (HsDo PArrComp stmts _) = dsPArrComp (map unLoc stmts) +dsExpr (HsDo DoExpr stmts _) = dsDo stmts +dsExpr (HsDo GhciStmt stmts _) = dsDo stmts +dsExpr (HsDo MDoExpr stmts _) = dsDo stmts +dsExpr (HsDo MonadComp stmts _) = dsMonadComp stmts dsExpr (HsIf mb_fun guard_expr then_expr else_expr) = do { pred <- dsLExpr guard_expr @@ -537,12 +523,12 @@ dsExpr expr@(RecordUpd record_expr (HsRecFields { rec_flds = fields }) mk_alt upd_fld_env con = do { let (univ_tvs, ex_tvs, eq_spec, - eq_theta, dict_theta, arg_tys, _) = dataConFullSig con + theta, arg_tys, _) = dataConFullSig con subst = mkTopTvSubst (univ_tvs `zip` in_inst_tys) -- I'm not bothering to clone the ex_tvs ; eqs_vars <- mapM newPredVarDs (substTheta subst (eqSpecPreds eq_spec)) - ; theta_vars <- mapM newPredVarDs (substTheta subst (eq_theta ++ dict_theta)) + ; theta_vars <- mapM newPredVarDs (substTheta subst theta) ; arg_ids <- newSysLocalsDs (substTys subst arg_tys) ; let val_args = zipWithEqual "dsExpr:RecordUpd" mk_val_arg (dataConFieldLabels con) arg_ids @@ -553,21 +539,21 @@ dsExpr expr@(RecordUpd record_expr (HsRecFields { rec_flds = fields }) wrap = mkWpEvVarApps theta_vars `WpCompose` mkWpTyApps (mkTyVarTys ex_tvs) `WpCompose` mkWpTyApps [ty | (tv, ty) <- univ_tvs `zip` out_inst_tys - , isNothing (lookupTyVar wrap_subst tv) ] + , not (tv `elemVarEnv` wrap_subst) ] rhs = foldl (\a b -> nlHsApp a b) inst_con val_args -- Tediously wrap the application in a cast -- Note [Update for GADTs] wrapped_rhs | null eq_spec = rhs | otherwise = mkLHsWrap (WpCast wrap_co) rhs - wrap_co = mkTyConApp tycon [ lookup tv ty - | (tv,ty) <- univ_tvs `zip` out_inst_tys] - lookup univ_tv ty = case lookupTyVar wrap_subst univ_tv of - Just ty' -> ty' - Nothing -> ty - wrap_subst = mkTopTvSubst [ (tv,mkSymCoercion (mkTyVarTy co_var)) - | ((tv,_),co_var) <- eq_spec `zip` eqs_vars ] - + wrap_co = mkTyConAppCo tycon [ lookup tv ty + | (tv,ty) <- univ_tvs `zip` out_inst_tys] + lookup univ_tv ty = case lookupVarEnv wrap_subst univ_tv of + Just co' -> co' + Nothing -> mkReflCo ty + wrap_subst = mkVarEnv [ (tv, mkSymCo (mkCoVarCo co_var)) + | ((tv,_),co_var) <- eq_spec `zip` eqs_vars ] + pat = noLoc $ ConPatOut { pat_con = noLoc con, pat_tvs = ex_tvs , pat_dicts = eqs_vars ++ theta_vars , pat_binds = emptyTcEvBinds @@ -607,7 +593,7 @@ dsExpr (HsTick ix vars e) = do dsExpr (HsBinTick ixT ixF e) = do e2 <- dsLExpr e - do { ASSERT(exprType e2 `coreEqType` boolTy) + do { ASSERT(exprType e2 `eqType` boolTy) mkBinaryTickBox ixT ixF e2 } \end{code} @@ -718,25 +704,20 @@ handled in DsListComp). Basically does the translation given in the Haskell 98 report: \begin{code} -dsDo :: [LStmt Id] - -> LHsExpr Id - -> Type -- Type of the whole expression - -> DsM CoreExpr - -dsDo stmts body result_ty +dsDo :: [LStmt Id] -> DsM CoreExpr +dsDo stmts = goL stmts where - -- result_ty must be of the form (m b) - (m_ty, _b_ty) = tcSplitAppTy result_ty - - goL [] = dsLExpr body - goL ((L loc stmt):lstmts) = putSrcSpanDs loc (go loc stmt lstmts) + goL [] = panic "dsDo" + goL (L loc stmt:lstmts) = putSrcSpanDs loc (go loc stmt lstmts) - go _ (ExprStmt rhs then_expr _) stmts + go _ (LastStmt body _) stmts + = ASSERT( null stmts ) dsLExpr body + -- The 'return' op isn't used for 'do' expressions + + go _ (ExprStmt rhs then_expr _ _) stmts = do { rhs2 <- dsLExpr rhs - ; case tcSplitAppTy_maybe (exprType rhs2) of - Just (container_ty, returning_ty) -> warnDiscardedDoBindings rhs container_ty returning_ty - _ -> return () + ; warnDiscardedDoBindings rhs (exprType rhs2) ; then_expr2 <- dsExpr then_expr ; rest <- goL stmts ; return (mkApps then_expr2 [rhs2, rest]) } @@ -760,29 +741,29 @@ dsDo stmts body result_ty go loc (RecStmt { recS_stmts = rec_stmts, recS_later_ids = later_ids , recS_rec_ids = rec_ids, recS_ret_fn = return_op , recS_mfix_fn = mfix_op, recS_bind_fn = bind_op - , recS_rec_rets = rec_rets }) stmts + , recS_rec_rets = rec_rets, recS_ret_ty = body_ty }) stmts = ASSERT( length rec_ids > 0 ) goL (new_bind_stmt : stmts) where - -- returnE <- dsExpr return_id - -- mfixE <- dsExpr mfix_id - new_bind_stmt = L loc $ BindStmt (mkLHsPatTup later_pats) mfix_app - bind_op + new_bind_stmt = L loc $ BindStmt (mkLHsPatTup later_pats) + mfix_app bind_op noSyntaxExpr -- Tuple cannot fail tup_ids = rec_ids ++ filterOut (`elem` rec_ids) later_ids + tup_ty = mkBoxedTupleTy (map idType tup_ids) -- Deals with singleton case rec_tup_pats = map nlVarPat tup_ids later_pats = rec_tup_pats rets = map noLoc rec_rets - - mfix_app = nlHsApp (noLoc mfix_op) mfix_arg - mfix_arg = noLoc $ HsLam (MatchGroup [mkSimpleMatch [mfix_pat] body] - (mkFunTy tup_ty body_ty)) - mfix_pat = noLoc $ LazyPat $ mkLHsPatTup rec_tup_pats - body = noLoc $ HsDo DoExpr rec_stmts return_app body_ty - return_app = nlHsApp (noLoc return_op) (mkLHsTupleExpr rets) - body_ty = mkAppTy m_ty tup_ty - tup_ty = mkBoxedTupleTy (map idType tup_ids) -- Deals with singleton case + mfix_app = nlHsApp (noLoc mfix_op) mfix_arg + mfix_arg = noLoc $ HsLam (MatchGroup [mkSimpleMatch [mfix_pat] body] + (mkFunTy tup_ty body_ty)) + mfix_pat = noLoc $ LazyPat $ mkLHsPatTup rec_tup_pats + body = noLoc $ HsDo DoExpr (rec_stmts ++ [ret_stmt]) body_ty + ret_app = nlHsApp (noLoc return_op) (mkLHsTupleExpr rets) + ret_stmt = noLoc $ mkLastStmt ret_app + -- This LastStmt will be desugared with dsDo, + -- which ignores the return_op in the LastStmt, + -- so we must apply the return_op explicitly handle_failure :: LPat Id -> MatchResult -> SyntaxExpr Id -> DsM CoreExpr -- In a do expression, pattern-match failure just calls @@ -800,104 +781,6 @@ mk_fail_msg pat = "Pattern match failure in do expression at " ++ showSDoc (ppr (getLoc pat)) \end{code} -Translation for RecStmt's: ------------------------------ -We turn (RecStmt [v1,..vn] stmts) into: - - (v1,..,vn) <- mfix (\~(v1,..vn). do stmts - return (v1,..vn)) - -\begin{code} -{- -dsMDo :: HsStmtContext Name - -> [(Name,Id)] - -> [LStmt Id] - -> LHsExpr Id - -> Type -- Type of the whole expression - -> DsM CoreExpr - -dsMDo ctxt tbl stmts body result_ty - = goL stmts - where - goL [] = dsLExpr body - goL ((L loc stmt):lstmts) = putSrcSpanDs loc (go loc stmt lstmts) - - (m_ty, b_ty) = tcSplitAppTy result_ty -- result_ty must be of the form (m b) - return_id = lookupEvidence tbl returnMName - bind_id = lookupEvidence tbl bindMName - then_id = lookupEvidence tbl thenMName - fail_id = lookupEvidence tbl failMName - - go _ (LetStmt binds) stmts - = do { rest <- goL stmts - ; dsLocalBinds binds rest } - - go _ (ExprStmt rhs then_expr rhs_ty) stmts - = do { rhs2 <- dsLExpr rhs - ; warnDiscardedDoBindings rhs m_ty rhs_ty - ; then_expr2 <- dsExpr then_expr - ; rest <- goL stmts - ; return (mkApps then_expr2 [rhs2, rest]) } - - go _ (BindStmt pat rhs bind_op _) stmts - = do { body <- goL stmts - ; rhs' <- dsLExpr rhs - ; bind_op' <- dsExpr bind_op - ; var <- selectSimpleMatchVarL pat - ; match <- matchSinglePat (Var var) (StmtCtxt ctxt) pat - result_ty (cantFailMatchResult body) - ; match_code <- handle_failure pat match fail_op - ; return (mkApps bind_op [rhs', Lam var match_code]) } - - go loc (RecStmt { recS_stmts = rec_stmts, recS_later_ids = later_ids - , recS_rec_ids = rec_ids, recS_rec_rets = rec_rets - , recS_mfix_fn = mfix_op, recS_bind_fn = bind_op }) stmts - = ASSERT( length rec_ids > 0 ) - ASSERT( length rec_ids == length rec_rets ) - ASSERT( isEmptyTcEvBinds _ev_binds ) - pprTrace "dsMDo" (ppr later_ids) $ - goL (new_bind_stmt : stmts) - where - new_bind_stmt = L loc $ BindStmt (mk_tup_pat later_pats) mfix_app - bind_op noSyntaxExpr - - -- Remove the later_ids that appear (without fancy coercions) - -- in rec_rets, because there's no need to knot-tie them separately - -- See Note [RecStmt] in HsExpr - later_ids' = filter (`notElem` mono_rec_ids) later_ids - mono_rec_ids = [ id | HsVar id <- rec_rets ] - - mfix_app = nlHsApp (noLoc mfix_op) mfix_arg - mfix_arg = noLoc $ HsLam (MatchGroup [mkSimpleMatch [mfix_pat] body] - (mkFunTy tup_ty body_ty)) - - -- The rec_tup_pat must bind the rec_ids only; remember that the - -- trimmed_laters may share the same Names - -- Meanwhile, the later_pats must bind the later_vars - rec_tup_pats = map mk_wild_pat later_ids' ++ map nlVarPat rec_ids - later_pats = map nlVarPat later_ids' ++ map mk_later_pat rec_ids - rets = map nlHsVar later_ids' ++ map noLoc rec_rets - - mfix_pat = noLoc $ LazyPat $ mk_tup_pat rec_tup_pats - body = noLoc $ HsDo ctxt rec_stmts return_app body_ty - body_ty = mkAppTy m_ty tup_ty - tup_ty = mkBoxedTupleTy (map idType (later_ids' ++ rec_ids)) -- Deals with singleton case - - return_app = nlHsApp (noLoc return_op) (mkLHsTupleExpr rets) - - mk_wild_pat :: Id -> LPat Id - mk_wild_pat v = noLoc $ WildPat $ idType v - - mk_later_pat :: Id -> LPat Id - mk_later_pat v | v `elem` later_ids' = mk_wild_pat v - | otherwise = nlVarPat v - - mk_tup_pat :: [LPat Id] -> LPat Id - mk_tup_pat [p] = p - mk_tup_pat ps = noLoc $ mkVanillaTuplePat ps Boxed --} -\end{code} - %************************************************************************ %* * @@ -914,7 +797,7 @@ warnAboutIdentities (Var v) co_fn | idName v `elem` conversionNames , let fun_ty = exprType (co_fn (Var v)) , Just (arg_ty, res_ty) <- splitFunTy_maybe fun_ty - , arg_ty `tcEqType` res_ty -- So we are converting ty -> ty + , arg_ty `eqType` res_ty -- So we are converting ty -> ty = warnDs (vcat [ ptext (sLit "Call of") <+> ppr v <+> dcolon <+> ppr fun_ty , nest 2 $ ptext (sLit "can probably be omitted") , parens (ptext (sLit "Use -fno-warn-identities to suppress this messsage)")) @@ -937,30 +820,34 @@ conversionNames \begin{code} -- Warn about certain types of values discarded in monadic bindings (#3263) -warnDiscardedDoBindings :: LHsExpr Id -> Type -> Type -> DsM () -warnDiscardedDoBindings rhs container_ty returning_ty = do { - -- Warn about discarding non-() things in 'monadic' binding - ; warn_unused <- doptDs Opt_WarnUnusedDoBind - ; if warn_unused && not (returning_ty `tcEqType` unitTy) - then warnDs (unusedMonadBind rhs returning_ty) - else do { - -- Warn about discarding m a things in 'monadic' binding of the same type, - -- but only if we didn't already warn due to Opt_WarnUnusedDoBind - ; warn_wrong <- doptDs Opt_WarnWrongDoBind - ; case tcSplitAppTy_maybe returning_ty of - Just (returning_container_ty, _) -> when (warn_wrong && container_ty `tcEqType` returning_container_ty) $ - warnDs (wrongMonadBind rhs returning_ty) - _ -> return () } } +warnDiscardedDoBindings :: LHsExpr Id -> Type -> DsM () +warnDiscardedDoBindings rhs rhs_ty + | Just (m_ty, elt_ty) <- tcSplitAppTy_maybe rhs_ty + = do { -- Warn about discarding non-() things in 'monadic' binding + ; warn_unused <- doptDs Opt_WarnUnusedDoBind + ; if warn_unused && not (isUnitTy elt_ty) + then warnDs (unusedMonadBind rhs elt_ty) + else + -- Warn about discarding m a things in 'monadic' binding of the same type, + -- but only if we didn't already warn due to Opt_WarnUnusedDoBind + do { warn_wrong <- doptDs Opt_WarnWrongDoBind + ; case tcSplitAppTy_maybe elt_ty of + Just (elt_m_ty, _) | warn_wrong, m_ty `eqType` elt_m_ty + -> warnDs (wrongMonadBind rhs elt_ty) + _ -> return () } } + + | otherwise -- RHS does have type of form (m ty), which is wierd + = return () -- but at lesat this warning is irrelevant unusedMonadBind :: LHsExpr Id -> Type -> SDoc -unusedMonadBind rhs returning_ty - = ptext (sLit "A do-notation statement discarded a result of type") <+> ppr returning_ty <> dot $$ +unusedMonadBind rhs elt_ty + = ptext (sLit "A do-notation statement discarded a result of type") <+> ppr elt_ty <> dot $$ ptext (sLit "Suppress this warning by saying \"_ <- ") <> ppr rhs <> ptext (sLit "\",") $$ ptext (sLit "or by using the flag -fno-warn-unused-do-bind") wrongMonadBind :: LHsExpr Id -> Type -> SDoc -wrongMonadBind rhs returning_ty - = ptext (sLit "A do-notation statement discarded a result of type") <+> ppr returning_ty <> dot $$ +wrongMonadBind rhs elt_ty + = ptext (sLit "A do-notation statement discarded a result of type") <+> ppr elt_ty <> dot $$ ptext (sLit "Suppress this warning by saying \"_ <- ") <> ppr rhs <> ptext (sLit "\",") $$ ptext (sLit "or by using the flag -fno-warn-wrong-do-bind") \end{code}