From: simonpj Date: Tue, 27 Jan 1998 14:53:51 +0000 (+0000) Subject: [project @ 1998-01-27 14:53:40 by simonpj] X-Git-Tag: Approx_2487_patches~1053 X-Git-Url: http://git.megacz.com/?a=commitdiff_plain;h=8e3bfa9b311ee374bd904604216a01d727e78fa1;p=ghc-hetmet.git [project @ 1998-01-27 14:53:40 by simonpj] Fix misleading type checker error msgs; fix broken floatBind in Simplify.lhs --- diff --git a/ghc/compiler/simplCore/Simplify.lhs b/ghc/compiler/simplCore/Simplify.lhs index 97b698f..b996b72 100644 --- a/ghc/compiler/simplCore/Simplify.lhs +++ b/ghc/compiler/simplCore/Simplify.lhs @@ -947,7 +947,8 @@ simplNonRec env binder@(id,occ_info) rhs body_c body_ty -- Try let-from-let simpl_bind env (Let bind rhs) | let_floating_ok = tick LetFloatFromLet `thenSmpl_` - simplBind env (fix_up_demandedness will_be_demanded bind) + simplBind env (if will_be_demanded then bind + else un_demandify_bind bind) (\env -> simpl_bind env rhs) body_ty -- Try case-from-let; this deals with a strict let of error too @@ -1276,7 +1277,8 @@ floatBind env top_level bind returnSmpl binds' where - (binds', _, n_extras) = fltBind bind + binds' = fltBind bind + n_extras = sum (map no_of_binds binds') - no_of_binds bind float_lets = switchIsSet env SimplFloatLetsExposingWHNF always_float_let_from_let = switchIsSet env SimplAlwaysFloatLetsFromLets @@ -1284,27 +1286,22 @@ floatBind env top_level bind -- fltBind guarantees not to return leaky floats -- and all the binders of the floats have had their demand-info zapped fltBind (NonRec bndr rhs) - = (binds ++ [NonRec (un_demandify bndr) rhs'], - leakFree bndr rhs', - length binds) + = binds ++ [NonRec bndr rhs'] where (binds, rhs') = fltRhs rhs fltBind (Rec pairs) - = ([Rec (extras - ++ - binders `zip` rhss')], - and (zipWith leakFree binders rhss'), - length extras - ) - + = [Rec pairs'] where - (binders, rhss) = unzip pairs - (binds_s, rhss') = mapAndUnzip fltRhs rhss - extras = concat (map get_pairs (concat binds_s)) - - get_pairs (NonRec bndr rhs) = [(bndr,rhs)] - get_pairs (Rec pairs) = pairs + pairs' = concat [ let + (binds, rhs') = fltRhs rhs + in + foldr get_pairs [(bndr, rhs')] binds + | (bndr, rhs) <- pairs + ] + + get_pairs (NonRec bndr rhs) rest = (bndr,rhs) : rest + get_pairs (Rec pairs) rest = pairs ++ rest -- fltRhs has same invariant as fltBind fltRhs rhs @@ -1322,12 +1319,19 @@ floatBind env top_level bind -- fltExpr guarantees not to return leaky floats = (binds' ++ body_binds, body') where - (body_binds, body') = fltExpr body - (binds', binds_wont_leak, _) = fltBind bind + binds_wont_leak = all leakFreeBind binds' + (body_binds, body') = fltExpr body + binds' = fltBind (un_demandify_bind bind) fltExpr expr = ([], expr) -- Crude but effective +no_of_binds (NonRec _ _) = 1 +no_of_binds (Rec pairs) = length pairs + +leakFreeBind (NonRec bndr rhs) = leakFree bndr rhs +leakFreeBind (Rec pairs) = and [leakFree bndr rhs | (bndr, rhs) <- pairs] + leakFree (id,_) rhs = case getIdArity id of ArityAtLeast n | n > 0 -> True ArityExactly n | n > 0 -> True @@ -1358,16 +1362,14 @@ simplArg env (VarArg id) = lookupId env id \begin{code} --- fix_up_demandedness switches off the willBeDemanded Info field +-- un_demandify_bind switches off the willBeDemanded Info field -- for bindings floated out of a non-demanded let -fix_up_demandedness True {- Will be demanded -} bind - = bind -- Simple; no change to demand info needed -fix_up_demandedness False {- May not be demanded -} (NonRec binder rhs) - = NonRec (un_demandify binder) rhs -fix_up_demandedness False {- May not be demanded -} (Rec pairs) - = Rec [(un_demandify binder, rhs) | (binder,rhs) <- pairs] - -un_demandify (id, occ_info) = (id `addIdDemandInfo` noDemandInfo, occ_info) +un_demandify_bind (NonRec binder rhs) + = NonRec (un_demandify_bndr binder) rhs +un_demandify_bind (Rec pairs) + = Rec [(un_demandify_bndr binder, rhs) | (binder,rhs) <- pairs] + +un_demandify_bndr (id, occ_info) = (id `addIdDemandInfo` noDemandInfo, occ_info) is_cheap_prim_app (Prim op _) = primOpOkForSpeculation op is_cheap_prim_app other = False diff --git a/ghc/compiler/typecheck/TcExpr.lhs b/ghc/compiler/typecheck/TcExpr.lhs index 0ac4f08..34bb8cc 100644 --- a/ghc/compiler/typecheck/TcExpr.lhs +++ b/ghc/compiler/typecheck/TcExpr.lhs @@ -99,7 +99,7 @@ tcExpr :: RenamedHsExpr -- Expession to type check \begin{code} tcExpr (HsVar name) res_ty = tcId name `thenNF_Tc` \ (expr', lie, id_ty) -> - unifyTauTy id_ty res_ty `thenTc_` + unifyTauTy res_ty id_ty `thenTc_` -- Check that the result type doesn't have any nested for-alls. -- For example, a "build" on its own is no good; it must be @@ -306,16 +306,24 @@ tcExpr (HsLet binds expr) res_ty returnTc (expr', lie) combiner is_rec bind expr = HsLet (MonoBind bind [] is_rec) expr -tcExpr in_expr@(HsCase expr matches src_loc) res_ty - = tcAddSrcLoc src_loc $ - newTyVarTy mkTypeKind `thenNF_Tc` \ expr_ty -> - tcExpr expr expr_ty `thenTc` \ (expr',lie1) -> +tcExpr in_expr@(HsCase scrut matches src_loc) res_ty + = tcAddSrcLoc src_loc $ + tcAddErrCtxt (caseCtxt in_expr) $ + + -- Typecheck the case alternatives first. + -- The case patterns tend to give good type info to use + -- when typechecking the scrutinee. For example + -- case (map f) of + -- (x:xs) -> ... + -- will report that map is applied to too few arguments - tcAddErrCtxt (caseCtxt in_expr) $ - tcMatchesCase (mkFunTy expr_ty res_ty) matches - `thenTc` \ (matches',lie2) -> + tcMatchesCase res_ty matches `thenTc` \ (scrut_ty, matches', lie2) -> - returnTc (HsCase expr' matches' src_loc, plusLIE lie1 lie2) + tcAddErrCtxt (caseScrutCtxt scrut) ( + tcExpr scrut scrut_ty + ) `thenTc` \ (scrut',lie1) -> + + returnTc (HsCase scrut' matches' src_loc, plusLIE lie1 lie2) tcExpr (HsIf pred b1 b2 src_loc) res_ty = tcAddSrcLoc src_loc $ @@ -357,7 +365,7 @@ tcExpr (RecordCon con_name _ rbinds) res_ty in -- Con is syntactically constrained to be a data constructor ASSERT( maybeToBool (splitAlgTyConApp_maybe record_ty ) ) - unifyTauTy record_ty res_ty `thenTc_` + unifyTauTy res_ty record_ty `thenTc_` -- Check that the record bindings match the constructor let @@ -432,7 +440,7 @@ tcExpr (RecordUpd record_expr rbinds) res_ty let result_record_ty = mkTyConApp tycon result_inst_tys in - unifyTauTy result_record_ty res_ty `thenTc_` + unifyTauTy res_ty result_record_ty `thenTc_` tcRecordBinds result_record_ty rbinds `thenTc` \ (rbinds', rbinds_lie) -> -- STEP 4 @@ -1034,6 +1042,9 @@ arithSeqCtxt expr caseCtxt expr = hang (ptext SLIT("In the case expression:")) 4 (ppr expr) +caseScrutCtxt expr + = hang (ptext SLIT("In the scrutinee of a case expression:")) 4 (ppr expr) + exprSigCtxt expr = hang (ptext SLIT("In an expression with a type signature:")) 4 (ppr expr) diff --git a/ghc/compiler/typecheck/TcMatches.lhs b/ghc/compiler/typecheck/TcMatches.lhs index 69af3b2..9185d60 100644 --- a/ghc/compiler/typecheck/TcMatches.lhs +++ b/ghc/compiler/typecheck/TcMatches.lhs @@ -21,7 +21,7 @@ import TcMonad import Inst ( Inst, LIE, plusLIE ) import TcEnv ( TcIdOcc(..), newMonoIds ) import TcPat ( tcPat ) -import TcType ( TcType, TcMaybe, zonkTcType ) +import TcType ( TcType, TcMaybe, zonkTcType, newTyVarTy ) import TcSimplify ( bindInstsOfLocalFuns ) import Unify ( unifyTauTy, unifyTauTyList, unifyFunTy ) import Name ( Name {- instance Outputable -} ) @@ -78,8 +78,16 @@ tcMatchesFun fun_name expected_ty matches@(first_match:_) parser guarantees that each equation has exactly one argument. \begin{code} -tcMatchesCase :: TcType s -> [RenamedMatch] -> TcM s ([TcMatch s], LIE s) -tcMatchesCase expected_ty matches = tcMatchesExpected expected_ty MCase matches +tcMatchesCase :: TcType s -- Type of whole case expressions + -> [RenamedMatch] -- The case alternatives + -> TcM s (TcType s, -- Inferred type of the scrutinee + [TcMatch s], -- Translated alternatives + LIE s) + +tcMatchesCase expr_ty matches + = newTyVarTy mkTypeKind `thenNF_Tc` \ scrut_ty -> + tcMatchesExpected (mkFunTy scrut_ty expr_ty) MCase matches `thenTc` \ (matches', lie) -> + returnTc (scrut_ty, matches', lie) \end{code} diff --git a/ghc/compiler/typecheck/Unify.lhs b/ghc/compiler/typecheck/Unify.lhs index c5a29fc..439ccda 100644 --- a/ghc/compiler/typecheck/Unify.lhs +++ b/ghc/compiler/typecheck/Unify.lhs @@ -311,7 +311,7 @@ unifyFunTy ty unify_fun_ty_help ty -- Special cases failed, so revert to ordinary unification = newTyVarTy mkTypeKind `thenNF_Tc` \ arg -> newTyVarTy mkTypeKind `thenNF_Tc` \ res -> - unifyTauTy (mkFunTy arg res) ty `thenTc_` + unifyTauTy ty (mkFunTy arg res) `thenTc_` returnTc (arg,res) \end{code} @@ -332,7 +332,7 @@ unifyListTy ty unify_list_ty_help ty -- Revert to ordinary unification = newTyVarTy mkBoxedTypeKind `thenNF_Tc` \ elt_ty -> - unifyTauTy (mkListTy elt_ty) ty `thenTc_` + unifyTauTy ty (mkListTy elt_ty) `thenTc_` returnTc elt_ty \end{code} @@ -353,7 +353,7 @@ unifyTupleTy arity ty unify_tuple_ty_help arity ty = mapNF_Tc (\ _ -> newTyVarTy mkBoxedTypeKind) [1..arity] `thenNF_Tc` \ arg_tys -> - unifyTauTy (mkTupleTy arity arg_tys) ty `thenTc_` + unifyTauTy ty (mkTupleTy arity arg_tys) `thenTc_` returnTc arg_tys \end{code}