Commit 647eb486 authored by sof's avatar sof
Browse files

[project @ 1998-08-14 11:53:42 by sof]

Check type variable scoping (code currently not enabled);
parent ee67797f
......@@ -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}
......
......@@ -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}
%************************************************************************
......
......@@ -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
......
......@@ -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}
%************************************************************************
......
Supports Markdown
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment