Tidy up the treatment of dead binders

[ghc-hetmet.git] / compiler / vectorise / VectType.hs

diff --git a/compiler/vectorise/VectType.hs b/compiler/vectorise/VectType.hs
index 53c8a61..b4b3c43 100644 (file)
--- a/compiler/vectorise/VectType.hs
+++ b/compiler/vectorise/VectType.hs
@@ -12,6 +12,7 @@ import VectCore
 import HscTypes          ( TypeEnv, extendTypeEnvList, typeEnvTyCons )
 import CoreSyn
 import CoreUtils
+import MkCore           ( mkWildCase )
 import BuildTyCl
 import DataCon
 import TyCon
@@ -23,7 +24,6 @@ import OccName
 import MkId
 import BasicTypes        ( StrictnessMark(..), boolToRecFlag )
 import Var               ( Var, TyVar )
-import Id                ( mkWildId )
 import Name              ( Name, getOccName )
 import NameEnv
 import TysWiredIn
@@ -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 = pprPanic "vectType:" (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
@@ -461,7 +458,7 @@ buildToPRepr repr vect_tc prepr_tc _
             expr
       = do
           (vars, bodies) <- mapAndUnzipM to_unboxed prods
-          return . Case expr (mkWildId (exprType expr)) res_ty
+          return . mkWildCase expr (exprType expr) res_ty
                  $ zipWith4 mk_alt cons vars (tyConDataCons tycon) bodies
       where
         mk_alt con vars sum_con body
@@ -470,7 +467,7 @@ buildToPRepr repr vect_tc prepr_tc _
         ty_args = map (Type . reprType) prods
 
     to_repr (EnumRepr { enum_data_con = data_con }) expr
-      = return . Case expr (mkWildId (exprType expr)) res_ty
+      = return . mkWildCase expr (exprType expr) res_ty
                $ map mk_alt cons
       where
         mk_alt con = (DataAlt con, [], mkConApp data_con [mkDataConTag con])
@@ -478,7 +475,7 @@ buildToPRepr repr vect_tc prepr_tc _
     to_repr prod expr
       = do
           (vars, body) <- to_unboxed prod
-          return $ Case expr (mkWildId (exprType expr)) res_ty
+          return $ mkWildCase expr (exprType expr) res_ty
                    [(DataAlt con, vars, body)]
 
     to_unboxed (ProdRepr { prod_components = tys
@@ -521,7 +518,7 @@ buildFromPRepr repr vect_tc prepr_tc _
           vars   <- mapM (newLocalVar (fsLit "x")) (map reprType prods)
           bodies <- sequence . zipWith3 from_unboxed prods cons
                              $ map Var vars
-          return . Case expr (mkWildId (reprType repr)) res_ty
+          return . mkWildCase expr (reprType repr) res_ty
                  $ zipWith3 sum_alt (tyConDataCons tycon) vars bodies
       where
         sum_alt data_con var body = (DataAlt data_con, [var], body)
@@ -530,11 +527,11 @@ buildFromPRepr repr vect_tc prepr_tc _
       = do
           var <- newLocalVar (fsLit "n") intPrimTy
 
-          let res = Case (Var var) (mkWildId intPrimTy) res_ty
+          let res = mkWildCase (Var var) intPrimTy res_ty
                   $ (DEFAULT, [], error_expr)
                   : zipWith mk_alt (tyConDataCons vect_tc) cons
 
-          return $ Case expr (mkWildId (reprType repr)) res_ty
+          return $ mkWildCase expr (reprType repr) res_ty
                    [(DataAlt data_con, [var], res)]
       where
         mk_alt data_con con = (LitAlt (mkDataConTagLit data_con), [], con)
@@ -551,7 +548,7 @@ buildFromPRepr repr vect_tc prepr_tc _
               expr
       = do
           vars <- mapM (newLocalVar (fsLit "y")) tys
-          return $ Case expr (mkWildId (reprType prod)) res_ty
+          return $ mkWildCase expr (reprType prod) res_ty
                    [(DataAlt data_con, vars, con `mkVarApps` vars)]
 
     from_unboxed (IdRepr _) con expr
@@ -586,7 +583,7 @@ buildToArrPRepr repr vect_tc prepr_tc arr_tc
 
       return . Lam arg
              . mkCoerce co
-             $ Case scrut (mkWildId (mkTyConApp arr_tc var_tys)) res_ty
+             $ mkWildCase scrut (mkTyConApp arr_tc var_tys) res_ty
                [(DataAlt arr_dc, shape_vars ++ concat repr_vars, result)]
   where
     var_tys = mkTyVarTys $ tyConTyVars vect_tc
@@ -686,7 +683,7 @@ buildFromArrPRepr repr vect_tc prepr_tc arr_tc
           result <- go prods repr_vars vars body
 
           let scrut = unwrapFamInstScrut tycon ty_args expr
-          return . Case scrut (mkWildId scrut_ty) res_ty
+          return . mkWildCase scrut scrut_ty res_ty
                  $ [(DataAlt data_con, shape_vars ++ vars, result)]
       where
         ty_args  = map reprType prods
@@ -718,7 +715,7 @@ buildFromArrPRepr repr vect_tc prepr_tc arr_tc
           let scrut    = unwrapFamInstScrut tycon tys expr
               scrut_ty = mkTyConApp tycon tys
 
-          return $ Case scrut (mkWildId scrut_ty) res_ty
+          return $ mkWildCase scrut scrut_ty res_ty
                    [(DataAlt data_con, shape_vars ++ repr_vars, body)]
 
     from_prod (EnumRepr { enum_arr_tycon = tycon
@@ -731,7 +728,7 @@ buildFromArrPRepr repr vect_tc prepr_tc arr_tc
       = let scrut    = unwrapFamInstScrut tycon [] expr
             scrut_ty = mkTyConApp tycon []
         in
-        return $ Case scrut (mkWildId scrut_ty) res_ty
+        return $ mkWildCase scrut scrut_ty res_ty
                  [(DataAlt data_con, shape_vars, body)]
 
     from_prod (IdRepr _)