From 647eb48674623156f7f5b699e4ecee9410ff585f Mon Sep 17 00:00:00 2001 From: sof Date: Fri, 14 Aug 1998 11:53:46 +0000 Subject: [PATCH] [project @ 1998-08-14 11:53:42 by sof] Check type variable scoping (code currently not enabled); --- ghc/compiler/coreSyn/CoreLint.lhs | 109 +++++++++++++++++++++++------------- ghc/compiler/coreSyn/CoreUtils.lhs | 19 ++----- ghc/compiler/coreSyn/FreeVars.lhs | 11 ++-- ghc/compiler/coreSyn/PprCore.lhs | 9 +-- 4 files changed, 83 insertions(+), 65 deletions(-) diff --git a/ghc/compiler/coreSyn/CoreLint.lhs b/ghc/compiler/coreSyn/CoreLint.lhs index a7b9b97..7dada83 100644 --- a/ghc/compiler/coreSyn/CoreLint.lhs +++ b/ghc/compiler/coreSyn/CoreLint.lhs @@ -36,12 +36,17 @@ import PrimOp ( primOpType ) import PrimRep ( PrimRep(..) ) import SrcLoc ( SrcLoc ) import Type ( mkFunTy, splitFunTy_maybe, mkForAllTy, - splitForAllTy_maybe, + splitForAllTy_maybe, tyVarsOfType, isUnpointedType, typeKind, instantiateTy, splitAlgTyConApp_maybe, Type ) import TyCon ( TyCon, isPrimTyCon, isDataTyCon ) -import TyVar ( TyVar, tyVarKind, mkTyVarEnv ) +import TyVar ( TyVar, tyVarKind, mkTyVarEnv, + TyVarSet, + emptyTyVarSet, mkTyVarSet, isEmptyTyVarSet, + minusTyVarSet, elementOfTyVarSet, tyVarSetToList, + unionTyVarSets, intersectTyVarSets + ) import ErrUtils ( ErrMsg ) import Unique ( Unique ) import Util ( zipEqual ) @@ -248,16 +253,17 @@ lintCoreExpr e@(App fun arg) = lintCoreExpr fun `thenMaybeL` \ty -> lintCoreArg {-True-} e ty arg -- Note: we do check for primitive types in this argument -lintCoreExpr (Lam (ValBinder var) expr) - = addLoc (LambdaBodyOf var) +lintCoreExpr (Lam vb@(ValBinder var) expr) + = addLoc (LambdaBodyOf vb) (addInScopeVars [var] (lintCoreExpr expr `thenMaybeL` \ty -> returnL (Just (mkFunTy (idType var) ty)))) -lintCoreExpr (Lam (TyBinder tyvar) expr) - = lintCoreExpr expr `thenMaybeL` \ty -> - returnL (Just(mkForAllTy tyvar ty)) - -- ToDo: Should add in-scope type variable at this point +lintCoreExpr (Lam tb@(TyBinder tyvar) expr) + = addLoc (LambdaBodyOf tb) $ + addInScopeTyVars [tyvar] $ + lintCoreExpr expr `thenMaybeL` \ ty -> + returnL (Just(mkForAllTy tyvar ty)) lintCoreExpr e@(Case scrut alts) = lintCoreExpr scrut `thenMaybeL` \ty -> @@ -310,8 +316,8 @@ lintCoreArg e ty (VarArg v) var_ty = idType v lintCoreArg e ty a@(TyArg arg_ty) - = lintTy arg_ty `seqL` - + = lintTy arg_ty `seqL` + checkTyVarsInScope (tyVarsOfType arg_ty) `seqL` case (splitForAllTy_maybe ty) of Nothing -> addErrL (mkTyAppMsg SLIT("Illegal") ty arg_ty e) `seqL` returnL Nothing @@ -441,24 +447,29 @@ lintTy ty = returnL () type LintM a = Bool -- True <=> specialisation has been done -> [LintLocInfo] -- Locations -> IdSet -- Local vars in scope + -> TyVarSet -- Local tyvars in scope -> Bag ErrMsg -- Error messages so far -> (a, Bag ErrMsg) -- Result and error messages (if any) data LintLocInfo - = RhsOf Id -- The variable bound - | LambdaBodyOf Id -- The lambda-binder - | BodyOfLetRec [Id] -- One of the binders - | ImportedUnfolding SrcLoc -- Some imported unfolding (ToDo: say which) + = RhsOf Id -- The variable bound + | LambdaBodyOf CoreBinder -- The lambda-binder + | BodyOfLetRec [Id] -- One of the binders + | ImportedUnfolding SrcLoc -- Some imported unfolding (ToDo: say which) instance Outputable LintLocInfo where ppr (RhsOf v) = ppr (getSrcLoc v) <> colon <+> brackets (ptext SLIT("RHS of") <+> pp_binders [v]) - ppr (LambdaBodyOf b) + ppr (LambdaBodyOf (ValBinder b)) = ppr (getSrcLoc b) <> colon <+> brackets (ptext SLIT("in body of lambda with binder") <+> pp_binder b) + ppr (LambdaBodyOf (TyBinder b)) + = ppr (getSrcLoc b) <> colon <+> + brackets (ptext SLIT("in body of lambda with type binder") <+> ppr b) + ppr (BodyOfLetRec bs) = ppr (getSrcLoc (head bs)) <> colon <+> brackets (ptext SLIT("in body of letrec with binders") <+> pp_binders bs) @@ -477,7 +488,7 @@ pp_binder b = hsep [ppr b, text "::", ppr (idType b)] \begin{code} initL :: LintM a -> Bool -> Maybe ErrMsg initL m spec_done - = case (m spec_done [] emptyIdSet emptyBag) of { (_, errs) -> + = case (m spec_done [] emptyIdSet emptyTyVarSet emptyBag) of { (_, errs) -> if isEmptyBag errs then Nothing else @@ -485,23 +496,23 @@ initL m spec_done } returnL :: a -> LintM a -returnL r spec loc scope errs = (r, errs) +returnL r spec loc scope tyscope errs = (r, errs) thenL :: LintM a -> (a -> LintM b) -> LintM b -thenL m k spec loc scope errs - = case m spec loc scope errs of - (r, errs') -> k r spec loc scope errs' +thenL m k spec loc scope tyscope errs + = case m spec loc scope tyscope errs of + (r, errs') -> k r spec loc scope tyscope errs' seqL :: LintM a -> LintM b -> LintM b -seqL m k spec loc scope errs - = case m spec loc scope errs of - (_, errs') -> k spec loc scope errs' +seqL m k spec loc scope tyscope errs + = case m spec loc scope tyscope errs of + (_, errs') -> k spec loc scope tyscope errs' thenMaybeL :: LintM (Maybe a) -> (a -> LintM (Maybe b)) -> LintM (Maybe b) -thenMaybeL m k spec loc scope errs - = case m spec loc scope errs of +thenMaybeL m k spec loc scope tyscope errs + = case m spec loc scope tyscope errs of (Nothing, errs2) -> (Nothing, errs2) - (Just r, errs2) -> k r spec loc scope errs2 + (Just r, errs2) -> k r spec loc scope tyscope errs2 mapL :: (a -> LintM b) -> [a] -> LintM [b] mapL f [] = returnL [] @@ -521,20 +532,20 @@ mapMaybeL f (x:xs) \begin{code} checkL :: Bool -> ErrMsg -> LintM () -checkL True msg spec loc scope errs = ((), errs) -checkL False msg spec loc scope errs = ((), addErr errs msg loc) +checkL True msg spec loc scope tyscope errs = ((), errs) +checkL False msg spec loc scope tyscope errs = ((), addErr errs msg loc) checkIfSpecDoneL :: Bool -> ErrMsg -> LintM () -checkIfSpecDoneL True msg spec loc scope errs = ((), errs) -checkIfSpecDoneL False msg True loc scope errs = ((), addErr errs msg loc) -checkIfSpecDoneL False msg False loc scope errs = ((), errs) +checkIfSpecDoneL True msg spec loc scope tyscope errs = ((), errs) +checkIfSpecDoneL False msg True loc scope tyscope errs = ((), addErr errs msg loc) +checkIfSpecDoneL False msg False loc scope tyscope errs = ((), errs) ifSpecDoneL :: LintM () -> LintM () -ifSpecDoneL m False loc scope errs = ((), errs) -ifSpecDoneL m True loc scope errs = m True loc scope errs +ifSpecDoneL m False loc scope tyscope errs = ((), errs) +ifSpecDoneL m True loc scope tyscope errs = m True loc scope tyscope errs addErrL :: ErrMsg -> LintM () -addErrL msg spec loc scope errs = ((), addErr errs msg loc) +addErrL msg spec loc scope tyscope errs = ((), addErr errs msg loc) addErr :: Bag ErrMsg -> ErrMsg -> [LintLocInfo] -> Bag ErrMsg @@ -543,11 +554,11 @@ addErr errs_so_far msg locs errs_so_far `snocBag` (hang (ppr (head locs)) 4 msg) addLoc :: LintLocInfo -> LintM a -> LintM a -addLoc extra_loc m spec loc scope errs - = m spec (extra_loc:loc) scope errs +addLoc extra_loc m spec loc scope tyscope errs + = m spec (extra_loc:loc) scope tyscope errs addInScopeVars :: [Id] -> LintM a -> LintM a -addInScopeVars ids m spec loc scope errs +addInScopeVars ids m spec loc scope tyscope errs = -- We check if these "new" ids are already -- in scope, i.e., we have *shadowing* going on. -- For now, it's just a "trace"; we may make @@ -562,8 +573,15 @@ addInScopeVars ids m spec loc scope errs -- (if isEmptyUniqSet shadowed -- then id -- else pprTrace "Shadowed vars:" (ppr (uniqSetToList shadowed))) ( - m spec loc (scope `unionIdSets` new_set) errs + m spec loc (scope `unionIdSets` new_set) tyscope errs -- ) + +addInScopeTyVars :: [TyVar] -> LintM a -> LintM a +addInScopeTyVars tyvars m spec loc scope tyscope errs + = m spec loc scope (tyscope `unionTyVarSets` new_set) errs + where + new_set = mkTyVarSet tyvars + \end{code} \begin{code} @@ -579,7 +597,7 @@ checkSpecIdInScope binder id ppr binder checkInScope :: SDoc -> Id -> LintM () -checkInScope loc_msg id spec loc scope errs +checkInScope loc_msg id spec loc scope tyscope errs = let id_name = getName id in @@ -588,8 +606,19 @@ checkInScope loc_msg id spec loc scope errs else ((),errs) +checkTyVarsInScope :: TyVarSet -> LintM () +checkTyVarsInScope tyvars spec loc scope tyscope errs +-- | not (isEmptyTyVarSet out_of_scope) = ((), errs') + | otherwise = ((), errs) + where + out_of_scope = tyvars `minusTyVarSet` tyscope + errs' = + foldr (\ tv errs -> addErr errs (hsep [ppr tv, ptext SLIT("is out of scope")]) loc) + errs + (tyVarSetToList out_of_scope) + checkTys :: Type -> Type -> ErrMsg -> LintM () -checkTys ty1 ty2 msg spec loc scope errs +checkTys ty1 ty2 msg spec loc scope tyscope errs = if ty1 == ty2 then ((), errs) else ((), addErr errs msg loc) \end{code} diff --git a/ghc/compiler/coreSyn/CoreUtils.lhs b/ghc/compiler/coreSyn/CoreUtils.lhs index 62d57cf..7c1b62a 100644 --- a/ghc/compiler/coreSyn/CoreUtils.lhs +++ b/ghc/compiler/coreSyn/CoreUtils.lhs @@ -24,10 +24,8 @@ import CoreSyn import CostCentre ( isDictCC, CostCentre, noCostCentre ) import MkId ( mkSysLocal ) import Id ( idType, isBottomingId, getIdSpecialisation, - mkIdWithNewUniq, dataConRepType, - addOneToIdEnv, growIdEnvList, lookupIdEnv, - isNullIdEnv, IdEnv, Id + Id ) import Literal ( literalType, Literal(..) ) import Maybes ( catMaybes, maybeToBool ) @@ -35,26 +33,19 @@ import PprCore import PrimOp ( primOpType, PrimOp(..) ) import SpecEnv ( specEnvValues ) import SrcLoc ( noSrcLoc ) -import TyVar ( cloneTyVar, - isEmptyTyVarEnv, addToTyVarEnv, TyVarEnv, - TyVar, GenTyVar - ) import Type ( mkFunTy, mkForAllTy, mkTyVarTy, splitFunTy_maybe, applyTys, isUnpointedType, - splitSigmaTy, splitFunTys, instantiateTy, + splitSigmaTy, splitFunTys, Type ) import TysWiredIn ( trueDataCon, falseDataCon ) -import Unique ( Unique ) import BasicTypes ( Unused ) import UniqSupply ( returnUs, thenUs, - mapUs, mapAndUnzipUs, getUnique, - UniqSM, UniqSupply + mapAndUnzipUs, getUnique, + UniqSM ) -import Util ( zipEqual ) -import Outputable +import Outputable ( assertPanic, pprPanic, ppr, vcat, panic ) -type TypeEnv = TyVarEnv Type \end{code} %************************************************************************ diff --git a/ghc/compiler/coreSyn/FreeVars.lhs b/ghc/compiler/coreSyn/FreeVars.lhs index 5095994..d532494 100644 --- a/ghc/compiler/coreSyn/FreeVars.lhs +++ b/ghc/compiler/coreSyn/FreeVars.lhs @@ -28,13 +28,14 @@ import Id ( idType, getIdArity, isBottomingId, IdSet, Id ) import IdInfo ( ArityInfo(..) ) -import PrimOp ( PrimOp(..) ) +import PrimOp ( PrimOp(CCallOp) ) import Type ( tyVarsOfType, Type ) import TyVar ( emptyTyVarSet, unitTyVarSet, minusTyVarSet, intersectTyVarSets, unionManyTyVarSets, TyVarSet, TyVar ) import BasicTypes ( Unused ) + import UniqSet ( unionUniqSets, addOneToUniqSet, delOneFromUniqSet ) import Util ( panic, assertPanic ) @@ -169,8 +170,8 @@ fvExpr id_cands tyvar_cands (Prim op args) (args_fvs, tfvs) = freeArgs id_cands tyvar_cands args_to_use{-NB-} args_to_use = case op of - CCallOp _ _ _ _ res_ty -> TyArg res_ty : args - _ -> args + CCallOp _ _ _ _ _ res_ty -> TyArg res_ty : args + _ -> args -- this Lam stuff could probably be improved by rewriting (WDP 96/03) @@ -339,8 +340,8 @@ freeArgs icands tcands (arg:args) case (freeArgs icands tcands args) of { (irest, trest) -> (arg_fvs `combine` irest, tfvs `combine` trest) } where - free_arg (LitArg _) = noFreeAnything - free_arg (TyArg ty) = (noFreeIds, freeTy tcands ty) + free_arg (LitArg _) = noFreeAnything + free_arg (TyArg ty) = (noFreeIds, freeTy tcands ty) free_arg (VarArg v) | v `is_among` icands = (aFreeId v, noFreeTyVars) | otherwise = noFreeAnything diff --git a/ghc/compiler/coreSyn/PprCore.lhs b/ghc/compiler/coreSyn/PprCore.lhs index 14bd691..0bd3178 100644 --- a/ghc/compiler/coreSyn/PprCore.lhs +++ b/ghc/compiler/coreSyn/PprCore.lhs @@ -19,16 +19,13 @@ module PprCore ( import CoreSyn import CostCentre ( showCostCentre ) import Id ( idType, idInfo, isTupleCon, - DataCon, GenId{-instances-}, Id + GenId{-instances-}, Id ) -import IdInfo ( ppIdInfo, ppStrictnessInfo ) -import Literal ( Literal{-instances-} ) +import IdInfo ( ppIdInfo ) import Outputable -- quite a few things import PprEnv import PprType ( pprParendType, pprTyVarBndr ) -import PrimOp ( PrimOp{-instances-} ) -import TyVar ( GenTyVar{-instances-} ) -import Unique ( Unique{-instances-} ) + \end{code} %************************************************************************ -- 1.7.10.4