X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2FdeSugar%2FDsExpr.lhs;h=5db2175a506b522b31d6d24af05b1bfe627f5c03;hb=db4f42a8e38bfead11f5af78557e18b9f42b10b3;hp=9df432b989ee4938e5b644edbe11851d066db6f3;hpb=d2ce0f52d42edf32bb9f13796e6ba6edba8bd516;p=ghc-hetmet.git diff --git a/compiler/deSugar/DsExpr.lhs b/compiler/deSugar/DsExpr.lhs index 9df432b..5db2175 100644 --- a/compiler/deSugar/DsExpr.lhs +++ b/compiler/deSugar/DsExpr.lhs @@ -34,7 +34,6 @@ import DsMeta #endif import HsSyn -import TcHsSyn -- NB: The desugarer, which straddles the source and Core worlds, sometimes -- needs to see source types @@ -50,9 +49,8 @@ import DynFlags import StaticFlags import CostCentre import Id -import Var import VarSet -import PrelInfo +import VarEnv import DataCon import TysWiredIn import BasicTypes @@ -223,9 +221,13 @@ dsExpr (HsVar var) = return (Var var) dsExpr (HsIPVar ip) = return (Var (ipNameName ip)) dsExpr (HsLit lit) = dsLit lit dsExpr (HsOverLit lit) = dsOverLit lit -dsExpr (HsWrap co_fn e) = do { co_fn' <- dsHsWrapper co_fn - ; e' <- dsExpr e - ; return (co_fn' e') } + +dsExpr (HsWrap co_fn e) + = do { co_fn' <- dsHsWrapper co_fn + ; e' <- dsExpr e + ; warn_id <- doptDs Opt_WarnIdentities + ; when warn_id $ warnAboutIdentities e' co_fn' + ; return (co_fn' e') } dsExpr (NegApp expr neg_expr) = App <$> dsExpr neg_expr <*> dsLExpr expr @@ -335,10 +337,8 @@ dsExpr (HsDo DoExpr stmts body result_ty) dsExpr (HsDo GhciStmt stmts body result_ty) = dsDo stmts body result_ty -dsExpr (HsDo ctxt@(MDoExpr tbl) stmts body result_ty) - = do { (meth_binds, tbl') <- dsSyntaxTable tbl - ; core_expr <- dsMDo ctxt tbl' stmts body result_ty - ; return (mkLets meth_binds core_expr) } +dsExpr (HsDo MDoExpr stmts body result_ty) + = dsDo stmts body result_ty dsExpr (HsDo PArrComp stmts body result_ty) = -- Special case for array comprehensions @@ -346,8 +346,14 @@ dsExpr (HsDo PArrComp stmts body result_ty) where [elt_ty] = tcTyConAppArgs result_ty -dsExpr (HsIf guard_expr then_expr else_expr) - = mkIfThenElse <$> dsLExpr guard_expr <*> dsLExpr then_expr <*> dsLExpr else_expr +dsExpr (HsIf mb_fun guard_expr then_expr else_expr) + = do { pred <- dsLExpr guard_expr + ; b1 <- dsLExpr then_expr + ; b2 <- dsLExpr else_expr + ; case mb_fun of + Just fun -> do { core_fun <- dsExpr fun + ; return (mkCoreApps core_fun [pred,b1,b2]) } + Nothing -> return $ mkIfThenElse pred b1 b2 } \end{code} @@ -362,11 +368,11 @@ dsExpr (ExplicitList elt_ty xs) -- singletonP x1 +:+ ... +:+ singletonP xn -- dsExpr (ExplicitPArr ty []) = do - emptyP <- dsLookupGlobalId emptyPName + emptyP <- dsLookupDPHId emptyPName return (Var emptyP `App` Type ty) dsExpr (ExplicitPArr ty xs) = do - singletonP <- dsLookupGlobalId singletonPName - appP <- dsLookupGlobalId appPName + singletonP <- dsLookupDPHId singletonPName + appP <- dsLookupDPHId appPName xs' <- mapM dsLExpr xs return . foldr1 (binary appP) $ map (unary singletonP) xs' where @@ -521,12 +527,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 @@ -537,21 +543,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 @@ -591,7 +597,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} @@ -744,16 +750,15 @@ 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, recS_dicts = _ev_binds }) stmts + , recS_rec_rets = rec_rets }) stmts = ASSERT( length rec_ids > 0 ) - ASSERT( isEmptyTcEvBinds _ev_binds ) -- No method binds 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 - noSyntaxExpr -- Tuple cannot fail + noSyntaxExpr -- Tuple cannot fail tup_ids = rec_ids ++ filterOut (`elem` rec_ids) later_ids rec_tup_pats = map nlVarPat tup_ids @@ -769,15 +774,16 @@ dsDo stmts body result_ty body_ty = mkAppTy m_ty tup_ty tup_ty = mkBoxedTupleTy (map idType tup_ids) -- Deals with singleton case +handle_failure :: LPat Id -> MatchResult -> SyntaxExpr Id -> DsM CoreExpr -- In a do expression, pattern-match failure just calls -- the monadic 'fail' rather than throwing an exception - handle_failure pat match fail_op - | matchCanFail match - = do { fail_op' <- dsExpr fail_op - ; fail_msg <- mkStringExpr (mk_fail_msg pat) - ; extractMatchResult match (App fail_op' fail_msg) } - | otherwise - = extractMatchResult match (error "It can't fail") +handle_failure pat match fail_op + | matchCanFail match + = do { fail_op' <- dsExpr fail_op + ; fail_msg <- mkStringExpr (mk_fail_msg pat) + ; extractMatchResult match (App fail_op' fail_msg) } + | otherwise + = extractMatchResult match (error "It can't fail") mk_fail_msg :: Located e -> String mk_fail_msg pat = "Pattern match failure in do expression at " ++ @@ -792,7 +798,8 @@ We turn (RecStmt [v1,..vn] stmts) into: return (v1,..vn)) \begin{code} -dsMDo :: HsStmtContext Name +{- +dsMDo :: HsStmtContext Name -> [(Name,Id)] -> [LStmt Id] -> LHsExpr Id @@ -806,7 +813,6 @@ dsMDo ctxt tbl stmts body result_ty 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) - mfix_id = lookupEvidence tbl mfixName return_id = lookupEvidence tbl returnMName bind_id = lookupEvidence tbl bindMName then_id = lookupEvidence tbl thenMName @@ -816,35 +822,34 @@ dsMDo ctxt tbl stmts body result_ty = do { rest <- goL stmts ; dsLocalBinds binds rest } - go _ (ExprStmt rhs _ rhs_ty) stmts + 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 (Var then_id) [Type rhs_ty, Type b_ty, rhs2, rest]) } + ; return (mkApps then_expr2 [rhs2, rest]) } - go _ (BindStmt pat rhs _ _) stmts - = do { body <- goL stmts - ; var <- selectSimpleMatchVarL pat + 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) - ; fail_msg <- mkStringExpr (mk_fail_msg pat) - ; let fail_expr = mkApps (Var fail_id) [Type b_ty, fail_msg] - ; match_code <- extractMatchResult match fail_expr - - ; rhs' <- dsLExpr rhs - ; return (mkApps (Var bind_id) [Type (hsLPatType pat), Type b_ty, - rhs', Lam var match_code]) } + 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_dicts = _ev_binds }) stmts + , 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 $ mkBindStmt (mk_tup_pat later_pats) mfix_app + 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 @@ -852,7 +857,7 @@ dsMDo ctxt tbl stmts body result_ty later_ids' = filter (`notElem` mono_rec_ids) later_ids mono_rec_ids = [ id | HsVar id <- rec_rets ] - mfix_app = nlHsApp (nlHsTyApp mfix_id [tup_ty]) mfix_arg + mfix_app = nlHsApp (noLoc mfix_op) mfix_arg mfix_arg = noLoc $ HsLam (MatchGroup [mkSimpleMatch [mfix_pat] body] (mkFunTy tup_ty body_ty)) @@ -868,8 +873,7 @@ dsMDo ctxt tbl stmts body result_ty body_ty = mkAppTy m_ty tup_ty tup_ty = mkBoxedTupleTy (map idType (later_ids' ++ rec_ids)) -- Deals with singleton case - return_app = nlHsApp (nlHsTyApp return_id [tup_ty]) - (mkLHsTupleExpr rets) + return_app = nlHsApp (noLoc return_op) (mkLHsTupleExpr rets) mk_wild_pat :: Id -> LPat Id mk_wild_pat v = noLoc $ WildPat $ idType v @@ -881,11 +885,42 @@ dsMDo ctxt tbl stmts body result_ty mk_tup_pat :: [LPat Id] -> LPat Id mk_tup_pat [p] = p mk_tup_pat ps = noLoc $ mkVanillaTuplePat ps Boxed +-} \end{code} %************************************************************************ %* * + Warning about identities +%* * +%************************************************************************ + +Warn about functions that convert between one type and another +when the to- and from- types are the same. Then it's probably +(albeit not definitely) the identity +\begin{code} +warnAboutIdentities :: CoreExpr -> (CoreExpr -> CoreExpr) -> DsM () +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 `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)")) + ]) +warnAboutIdentities _ _ = return () + +conversionNames :: [Name] +conversionNames + = [ toIntegerName, toRationalName + , fromIntegralName, realToFracName ] + -- We can't easily add fromIntegerName, fromRationalName, + -- becuase they are generated by literals +\end{code} + +%************************************************************************ +%* * \subsection{Errors and contexts} %* * %************************************************************************ @@ -896,14 +931,14 @@ 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) + ; if warn_unused && not (returning_ty `eqType` 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) $ + Just (returning_container_ty, _) -> when (warn_wrong && container_ty `eqType` returning_container_ty) $ warnDs (wrongMonadBind rhs returning_ty) _ -> return () } }