X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2Fvectorise%2FVectType.hs;h=ffb43bb0c925aacfc95818a331aff57bcc34f032;hb=36104d7a0d66df895c8275e3aa7cfe35a322ff04;hp=42342c475f8483d560569a4ec2e6b324bd45bf2a;hpb=05535340ae496c57ff218e016da6649ca1640754;p=ghc-hetmet.git

diff --git a/compiler/vectorise/VectType.hs b/compiler/vectorise/VectType.hs
index 42342c4..ffb43bb 100644
--- a/compiler/vectorise/VectType.hs
+++ b/compiler/vectorise/VectType.hs
@@ -33,7 +33,7 @@ import Unique
 import UniqFM
 import UniqSet
 import Util
-import Digraph           ( SCC(..), stronglyConnComp )
+import Digraph           ( SCC(..), stronglyConnCompFromEdgedVertices )
 
 import Outputable
 import FastString
@@ -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
@@ -227,6 +224,7 @@ buildPReprTyCon orig_tc vect_tc
       liftDs $ buildSynTyCon name
                              tyvars
                              (SynonymTyCon rhs_ty)
+			     (typeKind rhs_ty)
                              (Just $ mk_fam_inst prepr_tc vect_tc)
   where
     tyvars = tyConTyVars vect_tc
@@ -430,7 +428,7 @@ arrReprVars repr
 mkRepr :: TyCon -> VM Repr
 mkRepr vect_tc
   | [tys] <- rep_tys = boxedProductRepr tys
-  -- | all null rep_tys = enumRepr
+  -- removed: | all null rep_tys = enumRepr
   | otherwise        = sumRepr =<< mapM unboxedProductRepr rep_tys
   where
     rep_tys = map dataConRepArgTys $ tyConDataCons vect_tc
@@ -979,7 +977,7 @@ classifyTyCons = classify [] []
 -- | Compute mutually recursive groups of tycons in topological order
 --
 tyConGroups :: [TyCon] -> [TyConGroup]
-tyConGroups tcs = map mk_grp (stronglyConnComp edges)
+tyConGroups tcs = map mk_grp (stronglyConnCompFromEdgedVertices edges)
   where
     edges = [((tc, ds), tc, uniqSetToList ds) | tc <- tcs
                                 , let ds = tyConsOfTyCon tc]