RichTokenStream support

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

diff --git a/compiler/vectorise/VectType.hs b/compiler/vectorise/VectType.hs
index 90a0825..ffb43bb 100644 (file)
--- a/compiler/vectorise/VectType.hs
+++ b/compiler/vectorise/VectType.hs
@@ -32,8 +32,8 @@ import TysPrim           ( intPrimTy )
 import Unique
 import UniqFM
 import UniqSet
-import Util              ( singleton )
-import Digraph           ( SCC(..), stronglyConnComp )
+import Util
+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
@@ -154,17 +149,14 @@ vectTypeEnv env
 vectTyConDecls :: [TyCon] -> VM [TyCon]
 vectTyConDecls tcs = fixV $ \tcs' ->
   do
-    mapM_ (uncurry defTyCon) (lazy_zip tcs tcs')
+    mapM_ (uncurry defTyCon) (zipLazy tcs tcs')
     mapM vectTyConDecl tcs
-  where
-    lazy_zip [] _ = []
-    lazy_zip (x:xs) ~(y:ys) = (x,y) : lazy_zip xs ys
 
 vectTyConDecl :: TyCon -> VM TyCon
 vectTyConDecl tc
   = do
       name' <- cloneName mkVectTyConOcc name
-      rhs'  <- vectAlgTyConRhs (algTyConRhs tc)
+      rhs'  <- vectAlgTyConRhs tc (algTyConRhs tc)
 
       liftDs $ buildAlgTyCon name'
                              tyvars
@@ -179,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
@@ -230,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
@@ -433,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
@@ -708,9 +703,9 @@ buildFromArrPRepr repr vect_tc prepr_tc arr_tc
 
     from_repr _ _ _ _ _ _ = panic "buildFromArrPRepr/from_repr"
 
-    from_prod prod@(ProdRepr { prod_components = tys
-                             , prod_arr_tycon  = tycon
-                             , prod_arr_data_con = data_con })
+    from_prod (ProdRepr { prod_components = tys
+                        , prod_arr_tycon  = tycon
+                        , prod_arr_data_con = data_con })
               expr
               shape_vars
               repr_vars
@@ -719,7 +714,6 @@ buildFromArrPRepr repr vect_tc prepr_tc arr_tc
       = do
           let scrut    = unwrapFamInstScrut tycon tys expr
               scrut_ty = mkTyConApp tycon tys
-          _ty <- arrReprType prod
 
           return $ Case scrut (mkWildId scrut_ty) res_ty
                    [(DataAlt data_con, shape_vars ++ repr_vars, body)]
@@ -983,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]