From: lewie Date: Sat, 13 May 2000 00:20:58 +0000 (+0000) Subject: [project @ 2000-05-13 00:20:57 by lewie] X-Git-Tag: Approximately_9120_patches~4476 X-Git-Url: http://git.megacz.com/?a=commitdiff_plain;h=6f122ef3930b51bca54bb96858fe9b8f1d85c461;p=ghc-hetmet.git [project @ 2000-05-13 00:20:57 by lewie] A clean-up pass on fundeps and implicit params. Haven't yet incorporated changes from Hugs/GHC meeting yet, tho. - Fixed up several places in Type.lhs where IPNotes were probably being incorrectly handled. Strongly suggests a better solution should be implemented for marking implicit params than piggybacking on NoteTys. - tcSimplifyAndCheck was handling implicit params incorrectly (holding on to them when it should have been booting them out to frees). - Improved improvement WRT type signatures (the signature is now taken into account when improving). - Added improvement when matching against local polymorphic types. --- diff --git a/ghc/compiler/hsSyn/HsDecls.lhs b/ghc/compiler/hsSyn/HsDecls.lhs index fe95b3c..7f47891 100644 --- a/ghc/compiler/hsSyn/HsDecls.lhs +++ b/ghc/compiler/hsSyn/HsDecls.lhs @@ -298,6 +298,9 @@ ppr_con_details con (RecCon fields) dcolon <+> ppr_bang ty +instance Outputable name => Outputable (BangType name) where + ppr = ppr_bang + ppr_bang (Banged ty) = ptext SLIT("!") <> pprParendHsType ty ppr_bang (Unbanged ty) = pprParendHsType ty ppr_bang (Unpacked ty) = ptext SLIT("! !") <> pprParendHsType ty diff --git a/ghc/compiler/typecheck/TcBinds.lhs b/ghc/compiler/typecheck/TcBinds.lhs index 1a36051..b252aca 100644 --- a/ghc/compiler/typecheck/TcBinds.lhs +++ b/ghc/compiler/typecheck/TcBinds.lhs @@ -259,7 +259,10 @@ tcBindWithSigs top_lvl mbind tc_ty_sigs inline_sigs is_rec -- come before: -- - computing vars over which to quantify -- - zonking the generalized type vars - tcImprove lie_req `thenTc_` + let lie_avail = case maybe_sig_theta of + Nothing -> emptyLIE + Just (_, la) -> la in + tcImprove (lie_avail `plusLIE` lie_req) `thenTc_` -- COMPUTE VARIABLES OVER WHICH TO QUANTIFY, namely tyvars_to_gen -- The tyvars_not_to_gen are free in the environment, and hence diff --git a/ghc/compiler/typecheck/TcExpr.lhs b/ghc/compiler/typecheck/TcExpr.lhs index 100a838..81b468f 100644 --- a/ghc/compiler/typecheck/TcExpr.lhs +++ b/ghc/compiler/typecheck/TcExpr.lhs @@ -38,6 +38,7 @@ import TcMatches ( tcMatchesCase, tcMatchLambda, tcStmts ) import TcMonoType ( tcHsSigType, checkSigTyVars, sigCtxt ) import TcPat ( badFieldCon ) import TcSimplify ( tcSimplify, tcSimplifyAndCheck, partitionPredsOfLIE ) +import TcImprove ( tcImprove ) import TcType ( TcType, TcTauType, tcInstTyVars, tcInstTcType, tcSplitRhoTy, @@ -60,7 +61,7 @@ import Type ( mkFunTy, mkAppTy, mkTyVarTy, mkTyVarTys, mkTyConApp, splitSigmaTy, splitRhoTy, isTauTy, tyVarsOfType, tyVarsOfTypes, - isForAllTy, splitAlgTyConApp, splitAlgTyConApp_maybe, + isSigmaTy, splitAlgTyConApp, splitAlgTyConApp_maybe, boxedTypeKind, mkArrowKind, tidyOpenType ) @@ -99,12 +100,12 @@ tcExpr :: RenamedHsExpr -- Expession to type check -> TcType -- Expected type (could be a polytpye) -> TcM s (TcExpr, LIE) -tcExpr expr ty | isForAllTy ty = -- Polymorphic case - tcPolyExpr expr ty `thenTc` \ (expr', lie, _, _, _) -> +tcExpr expr ty | isSigmaTy ty = -- Polymorphic case + tcPolyExpr expr ty `thenTc` \ (expr', lie, _, _, _) -> returnTc (expr', lie) - | otherwise = -- Monomorphic case - tcMonoExpr expr ty + | otherwise = -- Monomorphic case + tcMonoExpr expr ty \end{code} @@ -153,6 +154,7 @@ tcPolyExpr arg expected_arg_ty checkSigTyVars sig_tyvars free_tyvars `thenTc` \ zonked_sig_tyvars -> newDicts SignatureOrigin sig_theta `thenNF_Tc` \ (sig_dicts, dict_ids) -> + tcImprove (sig_dicts `plusLIE` lie_arg) `thenTc_` -- ToDo: better origin tcSimplifyAndCheck (text "the type signature of an expression") @@ -701,7 +703,7 @@ tcMonoExpr in_expr@(ExprWithTySig expr poly_ty) res_ty = tcSetErrCtxt (exprSigCtxt in_expr) $ tcHsSigType poly_ty `thenTc` \ sig_tc_ty -> - if not (isForAllTy sig_tc_ty) then + if not (isSigmaTy sig_tc_ty) then -- Easy case unifyTauTy sig_tc_ty res_ty `thenTc_` tcMonoExpr expr sig_tc_ty @@ -731,7 +733,6 @@ tcMonoExpr (HsWith expr binds) res_ty = tcMonoExpr expr res_ty `thenTc` \ (expr', lie) -> tcIPBinds binds `thenTc` \ (binds', types, lie2) -> partitionPredsOfLIE isBound lie `thenTc` \ (ips, lie', dict_binds) -> - pprTrace "tcMonoExpr With" (ppr (ips, lie', dict_binds)) $ let expr'' = if nullMonoBinds dict_binds then expr' else HsLet (mkMonoBind (revBinds dict_binds) [] NonRecursive) diff --git a/ghc/compiler/typecheck/TcForeign.lhs b/ghc/compiler/typecheck/TcForeign.lhs index 77e9e42..e814e06 100644 --- a/ghc/compiler/typecheck/TcForeign.lhs +++ b/ghc/compiler/typecheck/TcForeign.lhs @@ -41,9 +41,6 @@ import Name ( nameOccName ) import Type ( splitFunTys , splitTyConApp_maybe , splitForAllTys - , splitRhoTy - , isForAllTy - , mkForAllTys ) import PprType ( {- instance Outputable Type -} ) import TysWiredIn ( isFFIArgumentTy, isFFIResultTy, diff --git a/ghc/compiler/typecheck/TcSimplify.lhs b/ghc/compiler/typecheck/TcSimplify.lhs index f1467ba..08b2211 100644 --- a/ghc/compiler/typecheck/TcSimplify.lhs +++ b/ghc/compiler/typecheck/TcSimplify.lhs @@ -255,8 +255,8 @@ tcSimplify str local_tvs wanted_lie -- We're infering (not checking) the type, and -- the inst constrains a local type variable - | isDict inst = DontReduceUnlessConstant -- Dicts - | otherwise = ReduceMe AddToIrreds -- Lits and Methods + | isClassDict inst = DontReduceUnlessConstant -- Dicts + | otherwise = ReduceMe AddToIrreds -- Lits and Methods \end{code} @tcSimplifyAndCheck@ is similar to the above, except that it checks @@ -292,13 +292,13 @@ tcSimplifyAndCheck str local_tvs given_lie wanted_lie where givens = lieToList given_lie -- see comment on wanteds in tcSimplify - wanteds = filter notFunDep (lieToList wanted_lie) + -- JRL nope - it's too early to throw away fundeps here... + wanteds = {- filter notFunDep -} (lieToList wanted_lie) given_dicts = filter isClassDict givens try_me inst -- Does not constrain a local tyvar | isEmptyVarSet (tyVarsOfInst inst `intersectVarSet` local_tvs) - && (isDict inst || null (getIPs inst)) = Free -- When checking against a given signature we always reduce diff --git a/ghc/compiler/typecheck/TcTyClsDecls.lhs b/ghc/compiler/typecheck/TcTyClsDecls.lhs index 701c15c..a4c97df 100644 --- a/ghc/compiler/typecheck/TcTyClsDecls.lhs +++ b/ghc/compiler/typecheck/TcTyClsDecls.lhs @@ -39,7 +39,7 @@ import VarSet import Digraph ( stronglyConnComp, SCC(..) ) import Name ( Name, NamedThing(..), getSrcLoc, isTvOcc, nameOccName ) import Outputable -import Maybes ( mapMaybe, expectJust ) +import Maybes ( mapMaybe, catMaybes, expectJust ) import UniqSet ( UniqSet, emptyUniqSet, unitUniqSet, unionUniqSets, unionManyUniqSets, uniqSetToList ) @@ -272,7 +272,7 @@ Edges in Type/Class decls mk_cls_edges :: RenamedTyClDecl -> Maybe (RenamedTyClDecl, Unique, [Unique]) mk_cls_edges decl@(ClassDecl ctxt name _ _ _ _ _ _ _ _ _ _) - = Just (decl, getUnique name, map (getUnique . get_clas) ctxt) + = Just (decl, getUnique name, map getUnique (catMaybes (map get_clas ctxt))) mk_cls_edges other_decl = Nothing @@ -280,8 +280,8 @@ mk_cls_edges other_decl mk_edges :: RenamedTyClDecl -> (RenamedTyClDecl, Unique, [Unique]) mk_edges decl@(TyData _ ctxt name _ condecls derivs _ _) - = (decl, getUnique name, uniqSetToList (get_ctxt ctxt `unionUniqSets` - get_cons condecls `unionUniqSets` + = (decl, getUnique name, uniqSetToList (get_ctxt ctxt `unionUniqSets` + get_cons condecls `unionUniqSets` get_deriv derivs)) mk_edges decl@(TySynonym name _ rhs _) @@ -293,8 +293,9 @@ mk_edges decl@(ClassDecl ctxt name _ _ sigs _ _ _ _ _ _ _) ---------------------------------------------------- -get_ctxt ctxt = unionManyUniqSets (map (set_name . get_clas) ctxt) -get_clas (HsPClass clas _) = clas +get_ctxt ctxt = unionManyUniqSets (map set_name (catMaybes (map get_clas ctxt))) +get_clas (HsPClass clas _) = Just clas +get_clas _ = Nothing ---------------------------------------------------- get_deriv Nothing = emptyUniqSet diff --git a/ghc/compiler/typecheck/TcTyDecls.lhs b/ghc/compiler/typecheck/TcTyDecls.lhs index 36031cb..cf4a69d 100644 --- a/ghc/compiler/typecheck/TcTyDecls.lhs +++ b/ghc/compiler/typecheck/TcTyDecls.lhs @@ -45,7 +45,7 @@ import TyCon ( TyCon, AlgTyConFlavour(..), ArgVrcs, mkSynTyCon, mkAlgTyCon, ) import Type ( getTyVar, tyVarsOfTypes, splitFunTy, applyTys, mkTyConApp, mkTyVarTys, mkForAllTys, mkFunTy, - mkTyVarTy, splitForAllTys, isForAllTy, splitAlgTyConApp_maybe, + mkTyVarTy, splitAlgTyConApp_maybe, mkArrowKind, mkArrowKinds, boxedTypeKind, isUnboxedType, Type, ThetaType, classesOfPreds ) diff --git a/ghc/compiler/types/Type.lhs b/ghc/compiler/types/Type.lhs index 6ec5e2d..b54183e 100644 --- a/ghc/compiler/types/Type.lhs +++ b/ghc/compiler/types/Type.lhs @@ -44,13 +44,13 @@ module Type ( mkUsForAllTy, mkUsForAllTys, splitUsForAllTys, substUsTy, mkForAllTy, mkForAllTys, splitForAllTy_maybe, splitForAllTys, - isForAllTy, applyTy, applyTys, mkPiType, hoistForAllTys, + applyTy, applyTys, mkPiType, hoistForAllTys, TauType, RhoType, SigmaType, PredType(..), ThetaType, ClassPred, ClassContext, mkClassPred, getClassTys_maybe, ipName_maybe, classesToPreds, classesOfPreds, isTauTy, mkRhoTy, splitRhoTy, - mkSigmaTy, splitSigmaTy, + mkSigmaTy, isSigmaTy, splitSigmaTy, -- Lifting and boxity isUnLiftedType, isUnboxedType, isUnboxedTupleType, isAlgType, isDataType, isNewType, @@ -241,14 +241,17 @@ splitFunTy (FunTy arg res) = (arg, res) splitFunTy (NoteTy _ ty) = splitFunTy ty splitFunTy_maybe :: Type -> Maybe (Type, Type) -splitFunTy_maybe (FunTy arg res) = Just (arg, res) -splitFunTy_maybe (NoteTy _ ty) = splitFunTy_maybe ty -splitFunTy_maybe other = Nothing +splitFunTy_maybe (FunTy arg res) = Just (arg, res) +splitFunTy_maybe (NoteTy (IPNote _) ty) = Nothing +splitFunTy_maybe (NoteTy _ ty) = splitFunTy_maybe ty +splitFunTy_maybe other = Nothing splitFunTys :: Type -> ([Type], Type) splitFunTys ty = split [] ty ty where split args orig_ty (FunTy arg res) = split (arg:args) res res + split args orig_ty (NoteTy (IPNote _) ty) + = (reverse args, orig_ty) split args orig_ty (NoteTy _ ty) = split args orig_ty ty split args orig_ty ty = (reverse args, orig_ty) @@ -304,10 +307,11 @@ mkTyConTy tycon = ASSERT( not (isSynTyCon tycon) ) -- including functions are returned as Just .. splitTyConApp_maybe :: Type -> Maybe (TyCon, [Type]) -splitTyConApp_maybe (TyConApp tc tys) = Just (tc, tys) -splitTyConApp_maybe (FunTy arg res) = Just (funTyCon, [arg,res]) -splitTyConApp_maybe (NoteTy _ ty) = splitTyConApp_maybe ty -splitTyConApp_maybe other = Nothing +splitTyConApp_maybe (TyConApp tc tys) = Just (tc, tys) +splitTyConApp_maybe (FunTy arg res) = Just (funTyCon, [arg,res]) +splitTyConApp_maybe (NoteTy (IPNote _) ty) = Nothing +splitTyConApp_maybe (NoteTy _ ty) = splitTyConApp_maybe ty +splitTyConApp_maybe other = Nothing -- splitAlgTyConApp_maybe looks for -- *saturated* applications of *algebraic* data types @@ -318,6 +322,8 @@ splitAlgTyConApp_maybe :: Type -> Maybe (TyCon, [Type], [DataCon]) splitAlgTyConApp_maybe (TyConApp tc tys) | isAlgTyCon tc && tyConArity tc == length tys = Just (tc, tys, tyConDataCons tc) +splitAlgTyConApp_maybe (NoteTy (IPNote _) ty) + = Nothing splitAlgTyConApp_maybe (NoteTy _ ty) = splitAlgTyConApp_maybe ty splitAlgTyConApp_maybe other = Nothing @@ -448,6 +454,8 @@ typePrimRep ty = case repType ty of splitNewType_maybe :: Type -> Maybe Type -- Find the representation of a newtype, if it is one -- Looks through multiple levels of newtype, but does not look through for-alls +splitNewType_maybe (NoteTy (IPNote _) ty) + = Nothing splitNewType_maybe (NoteTy _ ty) = splitNewType_maybe ty splitNewType_maybe (TyConApp tc tys) = case newTyConRep tc of Just rep_ty -> ASSERT( length tys == tyConArity tc ) @@ -590,14 +598,10 @@ splitForAllTy_maybe ty = case splitUsgTy_maybe ty of return (tyvar, NoteTy (UsgNote usg) ty'') Nothing -> splitFAT_m ty where - splitFAT_m (NoteTy _ ty) = splitFAT_m ty - splitFAT_m (ForAllTy tyvar ty) = Just(tyvar, ty) - splitFAT_m _ = Nothing - -isForAllTy :: Type -> Bool -isForAllTy (NoteTy _ ty) = isForAllTy ty -isForAllTy (ForAllTy tyvar ty) = True -isForAllTy _ = False + splitFAT_m (NoteTy (IPNote _) ty) = Nothing + splitFAT_m (NoteTy _ ty) = splitFAT_m ty + splitFAT_m (ForAllTy tyvar ty) = Just(tyvar, ty) + splitFAT_m _ = Nothing splitForAllTys :: Type -> ([TyVar], Type) splitForAllTys ty = case splitUsgTy_maybe ty of @@ -605,9 +609,10 @@ splitForAllTys ty = case splitUsgTy_maybe ty of in (tvs, NoteTy (UsgNote usg) ty'') Nothing -> split ty ty [] where - split orig_ty (ForAllTy tv ty) tvs = split ty ty (tv:tvs) - split orig_ty (NoteTy _ ty) tvs = split orig_ty ty tvs - split orig_ty t tvs = (reverse tvs, orig_ty) + split orig_ty (ForAllTy tv ty) tvs = split ty ty (tv:tvs) + split orig_ty (NoteTy (IPNote _) ty) tvs = (reverse tvs, orig_ty) + split orig_ty (NoteTy _ ty) tvs = split orig_ty ty tvs + split orig_ty t tvs = (reverse tvs, orig_ty) \end{code} @mkPiType@ makes a (->) type or a forall type, depending on whether @@ -719,12 +724,13 @@ classesOfPreds theta = concatMap cvt theta \begin{code} isTauTy :: Type -> Bool -isTauTy (TyVarTy v) = True -isTauTy (TyConApp _ tys) = all isTauTy tys -isTauTy (AppTy a b) = isTauTy a && isTauTy b -isTauTy (FunTy a b) = isTauTy a && isTauTy b -isTauTy (NoteTy _ ty) = isTauTy ty -isTauTy other = False +isTauTy (TyVarTy v) = True +isTauTy (TyConApp _ tys) = all isTauTy tys +isTauTy (AppTy a b) = isTauTy a && isTauTy b +isTauTy (FunTy a b) = isTauTy a && isTauTy b +isTauTy (NoteTy (IPNote _) ty) = False +isTauTy (NoteTy _ ty) = isTauTy ty +isTauTy other = False \end{code} \begin{code} @@ -737,8 +743,9 @@ splitRhoTy ty = split ty ty [] split orig_ty (FunTy arg res) ts = case splitPredTy_maybe arg of Just p -> split res res (p:ts) Nothing -> (reverse ts, orig_ty) - split orig_ty (NoteTy _ ty) ts = split orig_ty ty ts - split orig_ty ty ts = (reverse ts, orig_ty) + split orig_ty (NoteTy (IPNote _) ty) ts = (reverse ts, orig_ty) + split orig_ty (NoteTy _ ty) ts = split orig_ty ty ts + split orig_ty ty ts = (reverse ts, orig_ty) \end{code} @@ -746,6 +753,17 @@ splitRhoTy ty = split ty ty [] \begin{code} mkSigmaTy tyvars theta tau = mkForAllTys tyvars (mkRhoTy theta tau) +isSigmaTy :: Type -> Bool +isSigmaTy (FunTy a b) = isPredTy a + where isPredTy (NoteTy (IPNote _) _) = True + -- JRL could be a dict ty, but that would be polymorphic, + -- and thus there would have been an outer ForAllTy + isPredTy _ = False +isSigmaTy (NoteTy (IPNote _) _) = False +isSigmaTy (NoteTy _ ty) = isSigmaTy ty +isSigmaTy (ForAllTy tyvar ty) = True +isSigmaTy _ = False + splitSigmaTy :: Type -> ([TyVar], [PredType], Type) splitSigmaTy ty = (tyvars, theta, tau) @@ -988,6 +1006,5 @@ seqNote :: TyNote -> () seqNote (SynNote ty) = seqType ty seqNote (FTVNote set) = sizeUniqSet set `seq` () seqNote (UsgNote usg) = usg `seq` () -seqNote (IPNote nm) = nm `seq` () +seqNote (IPNote nm) = nm `seq` () \end{code} -