%
-% (c) The GRASP/AQUA Project, Glasgow University, 1993-1995
+% (c) The GRASP/AQUA Project, Glasgow University, 1993-1996
%
\section[StgLint]{A ``lint'' pass to check for Stg correctness}
module StgLint ( lintStgBindings ) where
-import PrelInfo ( primOpType, mkFunTy, PrimOp(..), PrimRep
- IF_ATTACK_PRAGMAS(COMMA tagOf_PrimOp)
- IF_ATTACK_PRAGMAS(COMMA pprPrimOp)
+IMP_Ubiq(){-uitous-}
+
+import StgSyn
+
+import Bag ( Bag, emptyBag, isEmptyBag, snocBag, foldBag )
+import Id ( idType, isAlgCon, dataConArgTys,
+ emptyIdSet, isEmptyIdSet, elementOfIdSet,
+ mkIdSet, intersectIdSets,
+ unionIdSets, idSetToList, SYN_IE(IdSet),
+ GenId{-instanced NamedThing-}, SYN_IE(Id)
)
-import Type
-import Bag
-import Literal ( literalType, Literal )
-import Id ( idType, isDataCon,
- getInstantiatedDataConSig
+import Literal ( literalType, Literal{-instance Outputable-} )
+import Maybes ( catMaybes )
+import Name ( isLocallyDefined, getSrcLoc )
+import Outputable ( PprStyle, Outputable(..){-instance * []-} )
+import PprType ( GenType{-instance Outputable-}, TyCon )
+import Pretty -- quite a bit of it
+import PrimOp ( primOpType )
+import SrcLoc ( SrcLoc{-instance Outputable-} )
+import Type ( mkFunTys, splitFunTy, maybeAppDataTyConExpandingDicts,
+ isTyVarTy, eqTy, splitFunTyExpandingDicts, SYN_IE(Type)
)
-import Maybes
-import Outputable
-import Pretty
-import SrcLoc ( SrcLoc )
-import StgSyn
-import UniqSet
-import Util
+import TyCon ( isDataTyCon )
+import Util ( zipEqual, pprPanic, panic, panic# )
infixr 9 `thenL`, `thenL_`, `thenMaybeL`, `thenMaybeL_`
+
+unDictifyTy = panic "StgLint.unDictifyTy (ToDo)"
\end{code}
Checks for
lintStgBindings :: PprStyle -> String -> [StgBinding] -> [StgBinding]
lintStgBindings sty whodunnit binds
- = BSCC("StgLint")
+ = _scc_ "StgLint"
case (initL (lint_binds binds)) of
Nothing -> binds
- Just msg -> pprPanic "" (ppAboves [
- ppStr ("*** Stg Lint Errors: in "++whodunnit++" ***"),
+ Just msg -> pprPanic "" (vcat [
+ ptext SLIT("*** Stg Lint Errors: in "),text whodunnit, ptext SLIT(" ***"),
msg sty,
- ppStr "*** Offending Program ***",
- ppAboves (map (pprPlainStgBinding sty) binds),
- ppStr "*** End of Offense ***"])
- ESCC
+ ptext SLIT("*** Offending Program ***"),
+ pprStgBindings sty binds,
+ ptext SLIT("*** End of Offense ***")])
where
lint_binds :: [StgBinding] -> LintM ()
lintStgArg :: StgArg -> LintM (Maybe Type)
lintStgArg (StgLitArg lit) = returnL (Just (literalType lit))
+lintStgArg (StgConArg con) = returnL (Just (idType con))
lintStgArg a@(StgVarArg v)
= checkInScope v `thenL_`
returnL (Just (idType v))
= addLoc (LambdaBodyOf binders) (
addInScopeVars binders (
lintStgExpr expr `thenMaybeL` \ body_ty ->
- returnL (Just (foldr (mkFunTy . idType) body_ty binders))
+ returnL (Just (mkFunTys (map idType binders) body_ty))
))
lintStgRhs (StgRhsCon _ con args)
= lintStgExpr scrut `thenMaybeL` \ _ ->
-- Check that it is a data type
- case maybeDataTyCon scrut_ty of
- Nothing -> addErrL (mkCaseDataConMsg e) `thenL_`
- returnL Nothing
- Just (tycon, _, _)
+ case (maybeAppDataTyConExpandingDicts scrut_ty) of
+ Just (tycon, _, _) | isDataTyCon tycon
-> lintStgAlts alts scrut_ty tycon
+ other -> addErrL (mkCaseDataConMsg e) `thenL_`
+ returnL Nothing
where
scrut_ty = get_ty alts
lintStgAlts alts scrut_ty case_tycon
= (case alts of
StgAlgAlts _ alg_alts deflt ->
- chk_non_abstract_type case_tycon `thenL_`
mapL (lintAlgAlt scrut_ty) alg_alts `thenL` \ maybe_alt_tys ->
lintDeflt deflt scrut_ty `thenL` \ maybe_deflt_ty ->
returnL (maybe_deflt_ty : maybe_alt_tys)
returnL (Just first_ty)
where
check ty = checkTys first_ty ty (mkCaseAltMsg alts)
- where
- chk_non_abstract_type tycon
- = case (getTyConFamilySize tycon) of
- Nothing -> addErrL (mkCaseAbstractMsg tycon)
- Just _ -> returnL () -- that's cool
lintAlgAlt scrut_ty (con, args, _, rhs)
- = (case maybeDataTyCon scrut_ty of
+ = (case maybeAppDataTyConExpandingDicts scrut_ty of
Nothing ->
addErrL (mkAlgAltMsg1 scrut_ty)
Just (tycon, tys_applied, cons) ->
let
- (_, arg_tys, _) = getInstantiatedDataConSig con tys_applied
+ arg_tys = dataConArgTys con tys_applied
in
checkL (con `elem` cons) (mkAlgAltMsg2 scrut_ty con) `thenL_`
checkL (length arg_tys == length args) (mkAlgAltMsg3 con args)
`thenL_`
- mapL check (arg_tys `zipEqual` args) `thenL_`
+ mapL check (zipEqual "lintAlgAlt:stg" arg_tys args) `thenL_`
returnL ()
) `thenL_`
addInScopeVars args (
\begin{code}
type LintM a = [LintLocInfo] -- Locations
- -> UniqSet Id -- Local vars in scope
+ -> IdSet -- Local vars in scope
-> Bag ErrMsg -- Error messages so far
-> (a, Bag ErrMsg) -- Result and error messages (if any)
-type ErrMsg = PprStyle -> Pretty
+type ErrMsg = PprStyle -> Doc
data LintLocInfo
= RhsOf Id -- The variable bound
instance Outputable LintLocInfo where
ppr sty (RhsOf v)
- = ppBesides [ppr sty (getSrcLoc v), ppStr ": [RHS of ", pp_binders sty [v], ppStr "]"]
+ = hcat [ppr sty (getSrcLoc v), ptext SLIT(": [RHS of "), pp_binders sty [v], char ']']
ppr sty (LambdaBodyOf bs)
- = ppBesides [ppr sty (getSrcLoc (head bs)),
- ppStr ": [in body of lambda with binders ", pp_binders sty bs, ppStr "]"]
+ = hcat [ppr sty (getSrcLoc (head bs)),
+ ptext SLIT(": [in body of lambda with binders "), pp_binders sty bs, char ']']
ppr sty (BodyOfLetRec bs)
- = ppBesides [ppr sty (getSrcLoc (head bs)),
- ppStr ": [in body of letrec with binders ", pp_binders sty bs, ppStr "]"]
+ = hcat [ppr sty (getSrcLoc (head bs)),
+ ptext SLIT(": [in body of letrec with binders "), pp_binders sty bs, char ']']
-pp_binders :: PprStyle -> [Id] -> Pretty
+pp_binders :: PprStyle -> [Id] -> Doc
pp_binders sty bs
- = ppInterleave ppComma (map pp_binder bs)
+ = sep (punctuate comma (map pp_binder bs))
where
pp_binder b
- = ppCat [ppr sty b, ppStr "::", ppr sty (idType b)]
+ = hsep [ppr sty b, ptext SLIT("::"), ppr sty (idType b)]
\end{code}
\begin{code}
initL :: LintM a -> Maybe ErrMsg
initL m
- = case (m [] emptyUniqSet emptyBag) of { (_, errs) ->
+ = case (m [] emptyIdSet emptyBag) of { (_, errs) ->
if isEmptyBag errs then
Nothing
else
Just ( \ sty ->
- ppAboves [ msg sty | msg <- bagToList errs ]
+ foldBag ($$) ( \ msg -> msg sty ) empty errs
)
}
addErr errs_so_far msg locs
= errs_so_far `snocBag` ( \ sty ->
- ppHang (ppr sty (head locs)) 4 (msg sty)
+ hang (ppr sty (head locs)) 4 (msg sty)
)
addLoc :: LintLocInfo -> LintM a -> LintM a
-- For now, it's just a "trace"; we may make
-- a real error out of it...
let
- new_set = mkUniqSet ids
+ new_set = mkIdSet ids
- shadowed = scope `intersectUniqSets` new_set
+ shadowed = scope `intersectIdSets` new_set
in
-- After adding -fliberate-case, Simon decided he likes shadowed
-- names after all. WDP 94/07
--- (if isEmptyUniqSet shadowed
+-- (if isEmptyIdSet shadowed
-- then id
--- else pprTrace "Shadowed vars:" (ppr PprDebug (uniqSetToList shadowed))) (
- m loc (scope `unionUniqSets` new_set) errs
--- )
+-- else pprTrace "Shadowed vars:" (ppr PprDebug (idSetToList shadowed))) $
+ m loc (scope `unionIdSets` new_set) errs
\end{code}
\begin{code}
checkFunApp fun_ty arg_tys msg loc scope errs
= cfa res_ty expected_arg_tys arg_tys
where
- (_, expected_arg_tys, res_ty) = splitTypeWithDictsAsArgs fun_ty
+ (expected_arg_tys, res_ty) = splitFunTyExpandingDicts fun_ty
cfa res_ty expected [] -- Args have run out; that's fine
- = (Just (glueTyArgs expected res_ty), errs)
+ = (Just (mkFunTys expected res_ty), errs)
cfa res_ty [] arg_tys -- Expected arg tys ran out first;
-- first see if res_ty is a tyvar template;
-- otherwise, maybe res_ty is a
-- dictionary type which is actually a function?
- | isTyVarTemplateTy res_ty
+ | isTyVarTy res_ty
= (Just res_ty, errs)
| otherwise
- = case splitTyArgs (unDictifyTy res_ty) of
+ = case splitFunTy (unDictifyTy res_ty) of
([], _) -> (Nothing, addErr errs msg loc) -- Too many args
(new_expected, new_res) -> cfa new_res new_expected arg_tys
cfa res_ty (expected_arg_ty:expected_arg_tys) (arg_ty:arg_tys)
- = case (sleazy_cmp_ty expected_arg_ty arg_ty) of
- EQ_ -> cfa res_ty expected_arg_tys arg_tys
- _ -> (Nothing, addErr errs msg loc) -- Arg mis-match
+ = if (sleazy_eq_ty expected_arg_ty arg_ty)
+ then cfa res_ty expected_arg_tys arg_tys
+ else (Nothing, addErr errs msg loc) -- Arg mis-match
\end{code}
\begin{code}
checkInScope :: Id -> LintM ()
checkInScope id loc scope errs
- = if isLocallyDefined id && not (isDataCon id) && not (id `elementOfUniqSet` scope) then
- ((), addErr errs (\ sty -> ppCat [ppr sty id, ppStr "is out of scope"]) loc)
+ = if isLocallyDefined id && not (isAlgCon id) && not (id `elementOfIdSet` scope) then
+ ((), addErr errs (\ sty -> hsep [ppr sty id, ptext SLIT("is out of scope")]) loc)
else
((), errs)
checkTys :: Type -> Type -> ErrMsg -> LintM ()
checkTys ty1 ty2 msg loc scope errs
- = case (sleazy_cmp_ty ty1 ty2) of
- EQ_ -> ((), errs)
- other -> ((), addErr errs msg loc)
+ = if (sleazy_eq_ty ty1 ty2)
+ then ((), errs)
+ else ((), addErr errs msg loc)
\end{code}
\begin{code}
mkCaseAltMsg :: StgCaseAlts -> ErrMsg
mkCaseAltMsg alts sty
- = ppAbove (ppStr "In some case alternatives, type of alternatives not all same:")
+ = ($$) (text "In some case alternatives, type of alternatives not all same:")
-- LATER: (ppr sty alts)
(panic "mkCaseAltMsg")
mkCaseDataConMsg :: StgExpr -> ErrMsg
mkCaseDataConMsg expr sty
- = ppAbove (ppStr "A case scrutinee not a type-constructor type:")
+ = ($$) (ptext SLIT("A case scrutinee not a type-constructor type:"))
(pp_expr sty expr)
mkCaseAbstractMsg :: TyCon -> ErrMsg
mkCaseAbstractMsg tycon sty
- = ppAbove (ppStr "An algebraic case on an abstract type:")
+ = ($$) (ptext SLIT("An algebraic case on an abstract type:"))
(ppr sty tycon)
mkDefltMsg :: StgCaseDefault -> ErrMsg
mkDefltMsg deflt sty
- = ppAbove (ppStr "Binder in default case of a case expression doesn't match type of scrutinee:")
+ = ($$) (ptext SLIT("Binder in default case of a case expression doesn't match type of scrutinee:"))
--LATER: (ppr sty deflt)
(panic "mkDefltMsg")
mkFunAppMsg :: Type -> [Type] -> StgExpr -> ErrMsg
mkFunAppMsg fun_ty arg_tys expr sty
- = ppAboves [ppStr "In a function application, function type doesn't match arg types:",
- ppHang (ppStr "Function type:") 4 (ppr sty fun_ty),
- ppHang (ppStr "Arg types:") 4 (ppAboves (map (ppr sty) arg_tys)),
- ppHang (ppStr "Expression:") 4 (pp_expr sty expr)]
+ = vcat [text "In a function application, function type doesn't match arg types:",
+ hang (ptext SLIT("Function type:")) 4 (ppr sty fun_ty),
+ hang (ptext SLIT("Arg types:")) 4 (vcat (map (ppr sty) arg_tys)),
+ hang (ptext SLIT("Expression:")) 4 (pp_expr sty expr)]
mkRhsConMsg :: Type -> [Type] -> ErrMsg
mkRhsConMsg fun_ty arg_tys sty
- = ppAboves [ppStr "In a RHS constructor application, con type doesn't match arg types:",
- ppHang (ppStr "Constructor type:") 4 (ppr sty fun_ty),
- ppHang (ppStr "Arg types:") 4 (ppAboves (map (ppr sty) arg_tys))]
+ = vcat [text "In a RHS constructor application, con type doesn't match arg types:",
+ hang (ptext SLIT("Constructor type:")) 4 (ppr sty fun_ty),
+ hang (ptext SLIT("Arg types:")) 4 (vcat (map (ppr sty) arg_tys))]
mkUnappTyMsg :: Id -> Type -> ErrMsg
mkUnappTyMsg var ty sty
- = ppAboves [ppStr "Variable has a for-all type, but isn't applied to any types.",
- ppBeside (ppStr "Var: ") (ppr sty var),
- ppBeside (ppStr "Its type: ") (ppr sty ty)]
+ = vcat [text "Variable has a for-all type, but isn't applied to any types.",
+ (<>) (ptext SLIT("Var: ")) (ppr sty var),
+ (<>) (ptext SLIT("Its type: ")) (ppr sty ty)]
mkAlgAltMsg1 :: Type -> ErrMsg
mkAlgAltMsg1 ty sty
- = ppAbove (ppStr "In some case statement, type of scrutinee is not a data type:")
+ = ($$) (text "In some case statement, type of scrutinee is not a data type:")
(ppr sty ty)
mkAlgAltMsg2 :: Type -> Id -> ErrMsg
mkAlgAltMsg2 ty con sty
- = ppAboves [
- ppStr "In some algebraic case alternative, constructor is not a constructor of scrutinee type:",
+ = vcat [
+ text "In some algebraic case alternative, constructor is not a constructor of scrutinee type:",
ppr sty ty,
ppr sty con
]
mkAlgAltMsg3 :: Id -> [Id] -> ErrMsg
mkAlgAltMsg3 con alts sty
- = ppAboves [
- ppStr "In some algebraic case alternative, number of arguments doesn't match constructor:",
+ = vcat [
+ text "In some algebraic case alternative, number of arguments doesn't match constructor:",
ppr sty con,
ppr sty alts
]
mkAlgAltMsg4 :: Type -> Id -> ErrMsg
mkAlgAltMsg4 ty arg sty
- = ppAboves [
- ppStr "In some algebraic case alternative, type of argument doesn't match data constructor:",
+ = vcat [
+ text "In some algebraic case alternative, type of argument doesn't match data constructor:",
ppr sty ty,
ppr sty arg
]
mkPrimAltMsg :: (Literal, StgExpr) -> ErrMsg
mkPrimAltMsg alt sty
- = ppAbove (ppStr "In a primitive case alternative, type of literal doesn't match type of scrutinee:")
+ = ($$) (text "In a primitive case alternative, type of literal doesn't match type of scrutinee:")
(ppr sty alt)
mkRhsMsg :: Id -> Type -> ErrMsg
mkRhsMsg binder ty sty
- = ppAboves [ppCat [ppStr "The type of this binder doesn't match the type of its RHS:",
+ = vcat [hsep [ptext SLIT("The type of this binder doesn't match the type of its RHS:"),
ppr sty binder],
- ppCat [ppStr "Binder's type:", ppr sty (idType binder)],
- ppCat [ppStr "Rhs type:", ppr sty ty]
+ hsep [ptext SLIT("Binder's type:"), ppr sty (idType binder)],
+ hsep [ptext SLIT("Rhs type:"), ppr sty ty]
]
-pp_expr :: PprStyle -> StgExpr -> Pretty
+pp_expr :: PprStyle -> StgExpr -> Doc
pp_expr sty expr = ppr sty expr
-sleazy_cmp_ty ty1 ty2
+sleazy_eq_ty ty1 ty2
-- NB: probably severe overkill (WDP 95/04)
- = case (splitTypeWithDictsAsArgs ty1) of { (_,tyargs1,tyres1) ->
- case (splitTypeWithDictsAsArgs ty2) of { (_,tyargs2,tyres2) ->
+ = trace "StgLint.sleazy_eq_ty:use eqSimplTy?" $
+ case (splitFunTyExpandingDicts ty1) of { (tyargs1,tyres1) ->
+ case (splitFunTyExpandingDicts ty2) of { (tyargs2,tyres2) ->
let
- ty11 = glueTyArgs tyargs1 tyres1
- ty22 = glueTyArgs tyargs2 tyres2
+ ty11 = mkFunTys tyargs1 tyres1
+ ty22 = mkFunTys tyargs2 tyres2
in
- cmpUniType False{-!!!NOT PROPERLY!!!-} ty11 ty22
- }}
+ ty11 `eqTy` ty22 }}
\end{code}
projects / ghc-hetmet.git / blobdiff