X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2FcoreSyn%2FCoreLint.lhs;h=cff93925e22902db4420bec74b60790c59c1d746;hb=1fb1ab5d53a09607e7f6d2450806760688396387;hp=dc2b61ae2001fd5212b89a924daa260bc98ecbd3;hpb=b4255f2c320f852d7dfb0afc0bc9f64765aece0c;p=ghc-hetmet.git diff --git a/ghc/compiler/coreSyn/CoreLint.lhs b/ghc/compiler/coreSyn/CoreLint.lhs index dc2b61a..cff9392 100644 --- a/ghc/compiler/coreSyn/CoreLint.lhs +++ b/ghc/compiler/coreSyn/CoreLint.lhs @@ -1,5 +1,5 @@ % -% (c) The GRASP/AQUA Project, Glasgow University, 1993-1995 +% (c) The GRASP/AQUA Project, Glasgow University, 1993-1996 % \section[CoreLint]{A ``lint'' pass to check for Core correctness} @@ -11,18 +11,20 @@ module CoreLint ( lintUnfolding ) where -import Ubiq +IMP_Ubiq() import CoreSyn import Bag -import Kind ( Kind{-instance-} ) +import Kind ( hasMoreBoxityInfo, Kind{-instance-} ) import Literal ( literalType, Literal{-instance-} ) -import Id ( idType, isBottomingId, - dataConArgTys, GenId{-instances-} +import Id ( idType, isBottomingId, dataConRepType, + dataConArgTys, GenId{-instances-}, + emptyIdSet, mkIdSet, intersectIdSets, + unionIdSets, elementOfIdSet, SYN_IE(IdSet) ) import Maybes ( catMaybes ) -import Name ( isLocallyDefined, getSrcLoc ) +import Name ( isLocallyDefined, getSrcLoc, Name{-instance NamedThing-} ) import Outputable ( Outputable(..){-instance * []-} ) import PprCore import PprStyle ( PprStyle(..) ) @@ -31,18 +33,18 @@ import Pretty import PrimOp ( primOpType, PrimOp(..) ) import PrimRep ( PrimRep(..) ) import SrcLoc ( SrcLoc ) -import Type ( mkFunTy,getFunTy_maybe,mkForAllTy,getForAllTy_maybe, - isPrimType,getTypeKind,instantiateTy, +import Type ( mkFunTy,getFunTy_maybe,mkForAllTy,mkForAllTys,getForAllTy_maybe, + getFunTyExpandingDicts_maybe, + getForAllTyExpandingDicts_maybe, + isPrimType,typeKind,instantiateTy,splitSigmaTy, mkForAllUsageTy,getForAllUsageTy,instantiateUsage, - maybeAppDataTyCon, eqTy - ) -import TyCon ( isPrimTyCon, tyConFamilySize ) -import TyVar ( getTyVarKind, GenTyVar{-instances-} ) -import UniqSet ( emptyUniqSet, mkUniqSet, intersectUniqSets, - unionUniqSets, elementOfUniqSet, UniqSet(..) + maybeAppDataTyConExpandingDicts, eqTy +-- ,expandTy -- ToDo:rm ) +import TyCon ( isPrimTyCon ) +import TyVar ( tyVarKind, GenTyVar{-instances-} ) import Unique ( Unique ) -import Usage ( GenUsage ) +import Usage ( GenUsage, SYN_IE(Usage) ) import Util ( zipEqual, pprTrace, pprPanic, assertPanic, panic ) infixr 9 `thenL`, `seqL`, `thenMaybeL`, `seqMaybeL` @@ -92,9 +94,9 @@ lintCoreBindings sty whoDunnit spec_done binds pprPanic "" (ppAboves [ ppStr ("*** Core Lint Errors: in " ++ whoDunnit ++ " ***"), msg sty, - ppStr "*** Offending Program ***", + ppPStr SLIT("*** Offending Program ***"), ppAboves (map (pprCoreBinding sty) binds), - ppStr "*** End of Offense ***" + ppPStr SLIT("*** End of Offense ***") ]) where lint_binds [] = returnL () @@ -124,9 +126,9 @@ lintUnfolding locn expr Just msg -> pprTrace "WARNING: Discarded bad unfolding from interface:\n" (ppAboves [msg PprForUser, - ppStr "*** Bad unfolding ***", + ppPStr SLIT("*** Bad unfolding ***"), ppr PprDebug expr, - ppStr "*** End unfolding ***"]) + ppPStr SLIT("*** End unfolding ***")]) Nothing \end{code} @@ -184,6 +186,8 @@ lintCoreExpr :: CoreExpr -> LintM (Maybe Type) -- Nothing if error found lintCoreExpr (Var var) = checkInScope var `seqL` returnL (Just (idType var)) lintCoreExpr (Lit lit) = returnL (Just (literalType lit)) lintCoreExpr (SCC _ expr) = lintCoreExpr expr +lintCoreExpr (Coerce _ ty expr) + = lintCoreExpr expr `seqL` returnL (Just ty) lintCoreExpr (Let binds body) = lintCoreBinding binds `thenL` \binders -> @@ -194,19 +198,19 @@ lintCoreExpr (Let binds body) (addInScopeVars binders (lintCoreExpr body)) lintCoreExpr e@(Con con args) - = lintCoreArgs False e (idType con) args + = lintCoreArgs {-False-} e (dataConRepType con) args -- Note: we don't check for primitive types in these arguments lintCoreExpr e@(Prim op args) - = lintCoreArgs True e (primOpType op) args + = lintCoreArgs {-True-} e (primOpType op) args -- Note: we do check for primitive types in these arguments lintCoreExpr e@(App fun@(Var v) arg) | isBottomingId v - = lintCoreExpr fun `thenMaybeL` \ ty -> lintCoreArg False e ty arg + = lintCoreExpr fun `thenMaybeL` \ ty -> lintCoreArg {-False-} e ty arg -- Note: we don't check for primitive types in argument to 'error' lintCoreExpr e@(App fun arg) - = lintCoreExpr fun `thenMaybeL` \ty -> lintCoreArg True e ty 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) @@ -218,14 +222,11 @@ lintCoreExpr (Lam (ValBinder var) expr) lintCoreExpr (Lam (TyBinder tyvar) expr) = lintCoreExpr expr `thenMaybeL` \ty -> returnL (Just(mkForAllTy tyvar ty)) - -- TODO: Should add in-scope type variable at this point + -- ToDo: Should add in-scope type variable at this point lintCoreExpr e@(Case scrut alts) = lintCoreExpr scrut `thenMaybeL` \ty -> - -- Check that it is a data type - case maybeAppDataTyCon ty of - Nothing -> addErrL (mkCaseDataConMsg e) `seqL` returnL Nothing - Just(tycon, _, _) -> lintCoreAlts alts ty tycon + lintCoreAlts alts ty \end{code} %************************************************************************ @@ -238,12 +239,12 @@ The boolean argument indicates whether we should flag type applications to primitive types as being errors. \begin{code} -lintCoreArgs :: Bool -> CoreExpr -> Type -> [CoreArg] -> LintM (Maybe Type) +lintCoreArgs :: {-Bool ->-} CoreExpr -> Type -> [CoreArg] -> LintM (Maybe Type) -lintCoreArgs _ _ ty [] = returnL (Just ty) -lintCoreArgs checkTyApp e ty (a : args) - = lintCoreArg checkTyApp e ty a `thenMaybeL` \ res -> - lintCoreArgs checkTyApp e res args +lintCoreArgs _ ty [] = returnL (Just ty) +lintCoreArgs e ty (a : args) + = lintCoreArg e ty a `thenMaybeL` \ res -> + lintCoreArgs e res args \end{code} %************************************************************************ @@ -253,36 +254,52 @@ lintCoreArgs checkTyApp e ty (a : args) %************************************************************************ \begin{code} -lintCoreArg :: Bool -> CoreExpr -> Type -> CoreArg -> LintM (Maybe Type) +lintCoreArg :: {-Bool ->-} CoreExpr -> Type -> CoreArg -> LintM (Maybe Type) -lintCoreArg _ e ty (LitArg lit) +lintCoreArg e ty (LitArg lit) = -- Make sure function type matches argument - case (getFunTy_maybe ty) of - Just (arg,res) | (literalType lit `eqTy` arg) -> returnL(Just res) - _ -> addErrL (mkAppMsg ty (literalType lit) e) `seqL` returnL Nothing + case (getFunTyExpandingDicts_maybe False{-no peeking in newtypes-} ty) of + Just (arg,res) | (lit_ty `eqTy` arg) -> returnL(Just res) + _ -> addErrL (mkAppMsg ty lit_ty e) `seqL` returnL Nothing + where + lit_ty = literalType lit -lintCoreArg _ e ty (VarArg v) +lintCoreArg e ty (VarArg v) = -- Make sure variable is bound checkInScope v `seqL` -- Make sure function type matches argument - case (getFunTy_maybe ty) of - Just (arg,res) | (idType v `eqTy` arg) -> returnL(Just res) - _ -> addErrL (mkAppMsg ty (idType v) e) `seqL` returnL Nothing - -lintCoreArg checkTyApp e ty a@(TyArg arg_ty) - = -- TODO: Check that ty is well-kinded and has no unbound tyvars - checkIfSpecDoneL (not (isPrimType arg_ty)) (mkSpecTyAppMsg a) - `seqL` - case (getForAllTy_maybe ty) of - Just (tyvar,body) | (getTyVarKind tyvar == getTypeKind arg_ty) -> - returnL(Just(instantiateTy [(tyvar,arg_ty)] body)) - _ -> addErrL (mkTyAppMsg ty arg_ty e) `seqL` returnL Nothing + case (getFunTyExpandingDicts_maybe False{-as above-} ty) of + Just (arg,res) | (var_ty `eqTy` arg) -> returnL(Just res) + _ -> addErrL (mkAppMsg ty var_ty e) `seqL` returnL Nothing + where + var_ty = idType v + +lintCoreArg e ty a@(TyArg arg_ty) + = -- ToDo: Check that ty is well-kinded and has no unbound tyvars + case (getForAllTyExpandingDicts_maybe ty) of + Nothing -> addErrL (mkTyAppMsg SLIT("Illegal") ty arg_ty e) `seqL` returnL Nothing + + Just (tyvar,body) -> + let + tyvar_kind = tyVarKind tyvar + argty_kind = typeKind arg_ty + in + if argty_kind `hasMoreBoxityInfo` tyvar_kind + -- Arg type might be boxed for a function with an uncommitted + -- tyvar; notably this is used so that we can give + -- error :: forall a:*. String -> a + -- and then apply it to both boxed and unboxed types. + then + returnL(Just(instantiateTy [(tyvar,arg_ty)] body)) + else + pprTrace "lintCoreArg:kinds:" (ppCat [ppr PprDebug tyvar_kind, ppr PprDebug argty_kind]) $ + addErrL (mkTyAppMsg SLIT("Kinds not right in") ty arg_ty e) `seqL` returnL Nothing -lintCoreArg _ e ty (UsageArg u) - = -- TODO: Check that usage has no unbound usage variables +lintCoreArg e ty (UsageArg u) + = -- ToDo: Check that usage has no unbound usage variables case (getForAllUsageTy ty) of Just (uvar,bounds,body) -> - -- TODO Check argument satisfies bounds + -- ToDo: Check argument satisfies bounds returnL(Just(panic "lintCoreArg:instantiateUsage uvar u body")) _ -> addErrL (mkUsageAppMsg ty u e) `seqL` returnL Nothing \end{code} @@ -296,20 +313,20 @@ lintCoreArg _ e ty (UsageArg u) \begin{code} lintCoreAlts :: CoreCaseAlts -> Type -- Type of scrutinee - -> TyCon -- TyCon pinned on the case +-- -> TyCon -- TyCon pinned on the case -> LintM (Maybe Type) -- Type of alternatives -lintCoreAlts whole_alts@(AlgAlts alts deflt) ty tycon +lintCoreAlts whole_alts@(AlgAlts alts deflt) ty --tycon = -- Check tycon is not a primitive tycon - addErrIfL (isPrimTyCon tycon) (mkCasePrimMsg tycon) - `seqL` +-- addErrIfL (isPrimTyCon tycon) (mkCasePrimMsg tycon) +-- `seqL` -- Check we are scrutinising a proper datatype -- (ToDo: robustify) - addErrIfL (not (tyConFamilySize tycon >= 1)) (mkCaseAbstractMsg tycon) - `seqL` +-- addErrIfL (not (tyConFamilySize tycon >= 1)) (mkCaseAbstractMsg tycon) +-- `seqL` lintDeflt deflt ty `thenL` \maybe_deflt_ty -> - mapL (lintAlgAlt ty tycon) alts + mapL (lintAlgAlt ty {-tycon-}) alts `thenL` \maybe_alt_tys -> -- Check the result types case catMaybes (maybe_deflt_ty : maybe_alt_tys) of @@ -320,10 +337,10 @@ lintCoreAlts whole_alts@(AlgAlts alts deflt) ty tycon where check ty = checkTys first_ty ty (mkCaseAltMsg whole_alts) -lintCoreAlts whole_alts@(PrimAlts alts deflt) ty tycon +lintCoreAlts whole_alts@(PrimAlts alts deflt) ty --tycon = -- Check tycon is a primitive tycon - addErrIfL (not (isPrimTyCon tycon)) (mkCaseNotPrimMsg tycon) - `seqL` +-- addErrIfL (not (isPrimTyCon tycon)) (mkCaseNotPrimMsg tycon) +-- `seqL` mapL (lintPrimAlt ty) alts `thenL` \maybe_alt_tys -> lintDeflt deflt ty @@ -337,8 +354,8 @@ lintCoreAlts whole_alts@(PrimAlts alts deflt) ty tycon where check ty = checkTys first_ty ty (mkCaseAltMsg whole_alts) -lintAlgAlt scrut_ty tycon{-ToDo: use it!-} (con,args,rhs) - = (case maybeAppDataTyCon scrut_ty of +lintAlgAlt scrut_ty {-tycon-ToDo: use it!-} (con,args,rhs) + = (case maybeAppDataTyConExpandingDicts scrut_ty of Nothing -> addErrL (mkAlgAltMsg1 scrut_ty) Just (tycon, tys_applied, cons) -> @@ -348,7 +365,7 @@ lintAlgAlt scrut_ty tycon{-ToDo: use it!-} (con,args,rhs) checkL (con `elem` cons) (mkAlgAltMsg2 scrut_ty con) `seqL` checkL (length arg_tys == length args) (mkAlgAltMsg3 con args) `seqL` - mapL check (arg_tys `zipEqual` args) `seqL` + mapL check (zipEqual "lintAlgAlt" arg_tys args) `seqL` returnL () ) `seqL` addInScopeVars args ( @@ -382,7 +399,7 @@ lintDeflt deflt@(BindDefault binder rhs) ty \begin{code} type LintM a = Bool -- True <=> specialisation has been done -> [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) @@ -396,18 +413,18 @@ data LintLocInfo instance Outputable LintLocInfo where ppr sty (RhsOf v) - = ppBesides [ppr sty (getSrcLoc v), ppStr ": [RHS of ", pp_binders sty [v], ppStr "]"] + = ppBesides [ppr sty (getSrcLoc v), ppPStr SLIT(": [RHS of "), pp_binders sty [v], ppChar ']'] ppr sty (LambdaBodyOf b) = ppBesides [ppr sty (getSrcLoc b), - ppStr ": [in body of lambda with binder ", pp_binder sty b, ppStr "]"] + ppPStr SLIT(": [in body of lambda with binder "), pp_binder sty b, ppChar ']'] ppr sty (BodyOfLetRec bs) = ppBesides [ppr sty (getSrcLoc (head bs)), - ppStr ": [in body of letrec with binders ", pp_binders sty bs, ppStr "]"] + ppPStr SLIT(": [in body of letrec with binders "), pp_binders sty bs, ppChar ']'] ppr sty (ImportedUnfolding locn) - = ppBeside (ppr sty locn) (ppStr ": [in an imported unfolding]") + = ppBeside (ppr sty locn) (ppPStr SLIT(": [in an imported unfolding]")) pp_binders :: PprStyle -> [Id] -> Pretty pp_binders sty bs = ppInterleave ppComma (map (pp_binder sty) bs) @@ -419,7 +436,7 @@ pp_binder sty b = ppCat [ppr sty b, ppStr "::", ppr sty (idType b)] \begin{code} initL :: LintM a -> Bool -> Maybe ErrMsg initL m spec_done - = case (m spec_done [] emptyUniqSet emptyBag) of { (_, errs) -> + = case (m spec_done [] emptyIdSet emptyBag) of { (_, errs) -> if isEmptyBag errs then Nothing else @@ -504,24 +521,27 @@ addInScopeVars ids m spec 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 -- then id -- else pprTrace "Shadowed vars:" (ppr PprDebug (uniqSetToList shadowed))) ( - m spec loc (scope `unionUniqSets` new_set) errs + m spec loc (scope `unionIdSets` new_set) errs -- ) \end{code} \begin{code} checkInScope :: Id -> LintM () checkInScope id spec loc scope errs - = if isLocallyDefined id && not (id `elementOfUniqSet` scope) then - ((),addErr errs (\sty -> ppCat [ppr sty id,ppStr "is out of scope"]) loc) + = let + id_name = getName id + in + if isLocallyDefined id_name && not (id `elementOfIdSet` scope) then + ((),addErr errs (\sty -> ppCat [ppr sty id, ppPStr SLIT("is out of scope")]) loc) else ((),errs) @@ -533,59 +553,60 @@ checkTys ty1 ty2 msg spec loc scope errs \begin{code} mkCaseAltMsg :: CoreCaseAlts -> ErrMsg mkCaseAltMsg alts sty - = ppAbove (ppStr "Type of case alternatives not the same:") + = ppAbove (ppPStr SLIT("Type of case alternatives not the same:")) (ppr sty alts) mkCaseDataConMsg :: CoreExpr -> ErrMsg mkCaseDataConMsg expr sty - = ppAbove (ppStr "A case scrutinee not of data constructor type:") + = ppAbove (ppPStr SLIT("A case scrutinee not of data constructor type:")) (pp_expr sty expr) mkCaseNotPrimMsg :: TyCon -> ErrMsg mkCaseNotPrimMsg tycon sty - = ppAbove (ppStr "A primitive case on a non-primitive type:") + = ppAbove (ppPStr SLIT("A primitive case on a non-primitive type:")) (ppr sty tycon) mkCasePrimMsg :: TyCon -> ErrMsg mkCasePrimMsg tycon sty - = ppAbove (ppStr "An algebraic case on a primitive type:") + = ppAbove (ppPStr SLIT("An algebraic case on a primitive type:")) (ppr sty tycon) mkCaseAbstractMsg :: TyCon -> ErrMsg mkCaseAbstractMsg tycon sty - = ppAbove (ppStr "An algebraic case on some weird type:") + = ppAbove (ppPStr SLIT("An algebraic case on some weird type:")) (ppr sty tycon) mkDefltMsg :: CoreCaseDefault -> ErrMsg mkDefltMsg deflt sty - = ppAbove (ppStr "Binder in case default doesn't match type of scrutinee:") + = ppAbove (ppPStr SLIT("Binder in case default doesn't match type of scrutinee:")) (ppr sty deflt) mkAppMsg :: Type -> Type -> CoreExpr -> ErrMsg mkAppMsg fun arg expr sty - = ppAboves [ppStr "Argument values doesn't match argument type:", - ppHang (ppStr "Fun type:") 4 (ppr sty fun), - ppHang (ppStr "Arg type:") 4 (ppr sty arg), - ppHang (ppStr "Expression:") 4 (pp_expr sty expr)] - -mkTyAppMsg :: Type -> Type -> CoreExpr -> ErrMsg -mkTyAppMsg ty arg expr sty - = ppAboves [ppStr "Illegal type application:", - ppHang (ppStr "Exp type:") 4 (ppr sty ty), - ppHang (ppStr "Arg type:") 4 (ppr sty arg), - ppHang (ppStr "Expression:") 4 (pp_expr sty expr)] + = ppAboves [ppPStr SLIT("Argument value doesn't match argument type:"), + ppHang (ppPStr SLIT("Fun type:")) 4 (ppr sty fun), + ppHang (ppPStr SLIT("Arg type:")) 4 (ppr sty arg), + ppHang (ppPStr SLIT("Expression:")) 4 (pp_expr sty expr)] + +mkTyAppMsg :: FAST_STRING -> Type -> Type -> CoreExpr -> ErrMsg +mkTyAppMsg msg ty arg expr sty + = ppAboves [ppCat [ppPStr msg, ppPStr SLIT("type application:")], + ppHang (ppPStr SLIT("Exp type:")) 4 (ppr sty ty), + ppHang (ppPStr SLIT("Arg type:")) 4 (ppr sty arg), + ppHang (ppPStr SLIT("Expression:")) 4 (pp_expr sty expr)] mkUsageAppMsg :: Type -> Usage -> CoreExpr -> ErrMsg mkUsageAppMsg ty u expr sty - = ppAboves [ppStr "Illegal usage application:", - ppHang (ppStr "Exp type:") 4 (ppr sty ty), - ppHang (ppStr "Usage exp:") 4 (ppr sty u), - ppHang (ppStr "Expression:") 4 (pp_expr sty expr)] + = ppAboves [ppPStr SLIT("Illegal usage application:"), + ppHang (ppPStr SLIT("Exp type:")) 4 (ppr sty ty), + ppHang (ppPStr SLIT("Usage exp:")) 4 (ppr sty u), + ppHang (ppPStr SLIT("Expression:")) 4 (pp_expr sty expr)] mkAlgAltMsg1 :: Type -> ErrMsg mkAlgAltMsg1 ty sty = ppAbove (ppStr "In some case statement, type of scrutinee is not a data type:") (ppr sty ty) +-- (ppAbove (ppr sty ty) (ppr sty (expandTy ty))) -- ToDo: rm mkAlgAltMsg2 :: Type -> Id -> ErrMsg mkAlgAltMsg2 ty con sty @@ -620,22 +641,22 @@ mkPrimAltMsg alt sty mkRhsMsg :: Id -> Type -> ErrMsg mkRhsMsg binder ty sty = ppAboves - [ppCat [ppStr "The type of this binder doesn't match the type of its RHS:", + [ppCat [ppPStr 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]] + ppCat [ppPStr SLIT("Binder's type:"), ppr sty (idType binder)], + ppCat [ppPStr SLIT("Rhs type:"), ppr sty ty]] mkRhsPrimMsg :: Id -> CoreExpr -> ErrMsg mkRhsPrimMsg binder rhs sty - = ppAboves [ppCat [ppStr "The type of this binder is primitive:", + = ppAboves [ppCat [ppPStr SLIT("The type of this binder is primitive:"), ppr sty binder], - ppCat [ppStr "Binder's type:", ppr sty (idType binder)] + ppCat [ppPStr SLIT("Binder's type:"), ppr sty (idType binder)] ] mkSpecTyAppMsg :: CoreArg -> ErrMsg mkSpecTyAppMsg arg sty = ppAbove - (ppStr "Unboxed types in a type application (after specialisation):") + (ppPStr SLIT("Unboxed types in a type application (after specialisation):")) (ppr sty arg) pp_expr :: PprStyle -> CoreExpr -> Pretty