X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2FstgSyn%2FStgLint.lhs;h=70bbf41a5879af7db2ced3cd0549c28bea4c005a;hb=bd8ead09270aec70f5495f1a2b20b6d2ea1ff44f;hp=29faa874ce054acc8c15cea347fc3ce296d37ded;hpb=6c381e873e222417d9a67aeec77b9555eca7b7a8;p=ghc-hetmet.git diff --git a/ghc/compiler/stgSyn/StgLint.lhs b/ghc/compiler/stgSyn/StgLint.lhs index 29faa87..70bbf41 100644 --- a/ghc/compiler/stgSyn/StgLint.lhs +++ b/ghc/compiler/stgSyn/StgLint.lhs @@ -1,5 +1,5 @@ % -% (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} @@ -8,25 +8,34 @@ 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 @@ -45,16 +54,15 @@ 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 () @@ -71,6 +79,7 @@ lintStgBindings sty whodunnit binds 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)) @@ -114,7 +123,7 @@ lintStgRhs (StgRhsClosure _ _ _ _ binders expr) = 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) @@ -172,11 +181,11 @@ lintStgExpr e@(StgCase scrut _ _ _ alts) = 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 @@ -193,7 +202,6 @@ lintStgAlts :: StgCaseAlts 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) @@ -211,24 +219,19 @@ lintStgAlts alts scrut_ty case_tycon 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 ( @@ -264,11 +267,11 @@ lintDeflt deflt@(StgBindDefault binder _ rhs) scrut_ty \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 @@ -277,33 +280,33 @@ data LintLocInfo 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 ) } @@ -360,7 +363,7 @@ addErr :: Bag ErrMsg -> ErrMsg -> [LintLocInfo] -> Bag ErrMsg 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 @@ -374,17 +377,16 @@ addInScopeVars ids m loc scope errs -- 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} @@ -396,138 +398,138 @@ checkFunApp :: Type -- The function type 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}