From: Roman Leshchinskiy Date: Tue, 16 Sep 2008 01:32:36 +0000 (+0000) Subject: Clean up vectorisation error messages X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=commitdiff_plain;h=3f6a74eafcabc1f8d496937a33ec92e7b416f989 Clean up vectorisation error messages --- diff --git a/compiler/vectorise/VectMonad.hs b/compiler/vectorise/VectMonad.hs index 2e100a9..56f5b8f 100644 --- a/compiler/vectorise/VectMonad.hs +++ b/compiler/vectorise/VectMonad.hs @@ -3,7 +3,7 @@ module VectMonad ( VM, noV, traceNoV, tryV, maybeV, traceMaybeV, orElseV, fixV, localV, closedV, - initV, + initV, cantVectorise, maybeCantVectorise, maybeCantVectoriseM, liftDs, cloneName, cloneId, cloneVar, newExportedVar, newLocalVar, newDummyVar, newTyVar, @@ -206,6 +206,25 @@ instance Monad VM where Yes genv' lenv' x -> runVM (f x) bi genv' lenv' No -> return No + +cantVectorise :: String -> SDoc -> a +cantVectorise s d = pgmError + . showSDocDump + $ vcat [text "*** Vectorisation error ***", + nest 4 $ sep [text s, nest 4 d]] + +maybeCantVectorise :: String -> SDoc -> Maybe a -> a +maybeCantVectorise s d Nothing = cantVectorise s d +maybeCantVectorise _ _ (Just x) = x + +maybeCantVectoriseM :: Monad m => String -> SDoc -> m (Maybe a) -> m a +maybeCantVectoriseM s d p + = do + r <- p + case r of + Just x -> return x + Nothing -> cantVectorise s d + noV :: VM a noV = VM $ \_ _ _ -> return No @@ -360,8 +379,8 @@ lookupVar v case r of Just e -> return (Local e) Nothing -> liftM Global - $ traceMaybeV "lookupVar" (ppr v) - (readGEnv $ \env -> lookupVarEnv (global_vars env) v) + . maybeCantVectoriseM "Variable not vectorised:" (ppr v) + . readGEnv $ \env -> lookupVarEnv (global_vars env) v lookupTyCon :: TyCon -> VM (Maybe TyCon) lookupTyCon tc diff --git a/compiler/vectorise/VectType.hs b/compiler/vectorise/VectType.hs index ae77d05..ffb43bb 100644 --- a/compiler/vectorise/VectType.hs +++ b/compiler/vectorise/VectType.hs @@ -49,13 +49,8 @@ vectTyCon tc | isFunTyCon tc = builtin closureTyCon | isBoxedTupleTyCon tc = return tc | isUnLiftedTyCon tc = return tc - | otherwise = do - r <- lookupTyCon tc - case r of - Just tc' -> return tc' - - -- FIXME: just for now - Nothing -> pprTrace "ccTyCon:" (ppr tc) $ return tc + | otherwise = maybeCantVectoriseM "Tycon not vectorised:" (ppr tc) + $ lookupTyCon tc vectAndLiftType :: Type -> VM (Type, Type) vectAndLiftType ty | Just ty' <- coreView ty = vectAndLiftType ty' @@ -86,7 +81,7 @@ vectType ty@(ForAllTy _ _) where (tyvars, mono_ty) = splitForAllTys ty -vectType ty = traceNoV "vectType: can't vectorise" (ppr ty) +vectType ty = cantVectorise "Can't vectorise type" (ppr ty) vectAndBoxType :: Type -> VM Type vectAndBoxType ty = vectType ty >>= boxType @@ -161,7 +156,7 @@ vectTyConDecl :: TyCon -> VM TyCon vectTyConDecl tc = do name' <- cloneName mkVectTyConOcc name - rhs' <- vectAlgTyConRhs (algTyConRhs tc) + rhs' <- vectAlgTyConRhs tc (algTyConRhs tc) liftDs $ buildAlgTyCon name' tyvars @@ -176,22 +171,24 @@ vectTyConDecl tc tyvars = tyConTyVars tc rec_flag = boolToRecFlag (isRecursiveTyCon tc) -vectAlgTyConRhs :: AlgTyConRhs -> VM AlgTyConRhs -vectAlgTyConRhs (DataTyCon { data_cons = data_cons - , is_enum = is_enum - }) +vectAlgTyConRhs :: TyCon -> AlgTyConRhs -> VM AlgTyConRhs +vectAlgTyConRhs _ (DataTyCon { data_cons = data_cons + , is_enum = is_enum + }) = do data_cons' <- mapM vectDataCon data_cons zipWithM_ defDataCon data_cons data_cons' return $ DataTyCon { data_cons = data_cons' , is_enum = is_enum } -vectAlgTyConRhs _ = panic "vectAlgTyConRhs" +vectAlgTyConRhs tc _ = cantVectorise "Can't vectorise type definition:" (ppr tc) vectDataCon :: DataCon -> VM DataCon vectDataCon dc - | not . null $ dataConExTyVars dc = pprPanic "vectDataCon: existentials" (ppr dc) - | not . null $ dataConEqSpec dc = pprPanic "vectDataCon: eq spec" (ppr dc) + | not . null $ dataConExTyVars dc + = cantVectorise "Can't vectorise constructor (existentials):" (ppr dc) + | not . null $ dataConEqSpec dc + = cantVectorise "Can't vectorise constructor (eq spec):" (ppr dc) | otherwise = do name' <- cloneName mkVectDataConOcc name diff --git a/compiler/vectorise/VectUtils.hs b/compiler/vectorise/VectUtils.hs index 2c37f73..3bf97fa 100644 --- a/compiler/vectorise/VectUtils.hs +++ b/compiler/vectorise/VectUtils.hs @@ -124,9 +124,10 @@ mkPArrayType :: Type -> VM Type mkPArrayType ty | Just tycon <- splitPrimTyCon ty = do - arr <- traceMaybeV "mkPArrayType" (ppr tycon) - $ lookupPrimPArray tycon - return $ mkTyConApp arr [] + r <- lookupPrimPArray tycon + case r of + Just arr -> return $ mkTyConApp arr [] + Nothing -> cantVectorise "Primitive tycon not vectorised" (ppr tycon) mkPArrayType ty = mkBuiltinTyConApp parrayTyCon [ty] mkBuiltinCo :: (Builtins -> TyCon) -> VM Coercion @@ -153,7 +154,9 @@ mkVScrut (ve, le) prDFunOfTyCon :: TyCon -> VM CoreExpr prDFunOfTyCon tycon - = liftM Var (traceMaybeV "prDictOfTyCon" (ppr tycon) (lookupTyConPR tycon)) + = liftM Var + . maybeCantVectoriseM "No PR dictionary for tycon" (ppr tycon) + $ lookupTyConPR tycon paDictArgType :: TyVar -> VM (Maybe Type) paDictArgType tv = go (TyVarTy tv) (tyVarKind tv) @@ -189,9 +192,11 @@ paDictOfTyApp (TyVarTy tv) ty_args paDFunApply dfun ty_args paDictOfTyApp (TyConApp tc _) ty_args = do - dfun <- traceMaybeV "paDictOfTyApp" (ppr tc) (lookupTyConPA tc) + dfun <- maybeCantVectoriseM "No PA dictionary for tycon" (ppr tc) + $ lookupTyConPA tc paDFunApply (Var dfun) ty_args -paDictOfTyApp ty _ = pprPanic "paDictOfTyApp" (ppr ty) +paDictOfTyApp ty _ + = cantVectorise "Can't construct PA dictionary for type" (ppr ty) paDFunType :: TyCon -> VM Type paDFunType tc @@ -221,10 +226,9 @@ pa_pack = (packPAVar, "packPA") paMethod :: PAMethod -> Type -> VM CoreExpr paMethod (_method, name) ty | Just tycon <- splitPrimTyCon ty - = do - fn <- traceMaybeV "paMethod" (ppr tycon <+> text name) - $ lookupPrimMethod tycon name - return (Var fn) + = liftM Var + . maybeCantVectoriseM "No PA method" (text name <+> text "for" <+> ppr tycon) + $ lookupPrimMethod tycon name paMethod (method, _name) ty = do diff --git a/compiler/vectorise/Vectorise.hs b/compiler/vectorise/Vectorise.hs index 70e69b7..c612a0a 100644 --- a/compiler/vectorise/Vectorise.hs +++ b/compiler/vectorise/Vectorise.hs @@ -275,7 +275,7 @@ vectExpr e@(fvs, AnnLam bndr _) where (bs,body) = collectAnnValBinders e -vectExpr e = traceNoV "vectExpr: can't vectorise" (ppr $ deAnnotate e) +vectExpr e = cantVectorise "Can't vectorise expression" (ppr $ deAnnotate e) vectLam :: VarSet -> [Var] -> CoreExprWithFVs -> VM VExpr vectLam fvs bs body @@ -298,7 +298,8 @@ vectLam fvs bs body vectTyAppExpr :: CoreExprWithFVs -> [Type] -> VM VExpr vectTyAppExpr (_, AnnVar v) tys = vectPolyVar v tys -vectTyAppExpr e _ = traceNoV "vectTyAppExpr: can't vectorise" (ppr $ deAnnotate e) +vectTyAppExpr e tys = cantVectorise "Can't vectorise expression" + (ppr $ deAnnotate e `mkTyApps` tys) -- We convert --