Clean up vectorisation error messages

4 files changed, 52 insertions, 31 deletions

diff --git a/compiler/vectorise/VectMonad.hs b/compiler/vectorise/VectMonad.hs
index 2e100a9223..56f5b8fa90 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 ae77d05b47..ffb43bb0c9 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 2c37f73aa5..3bf97fa7ff 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 70e69b7e90..c612a0a99d 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
 --