X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2Fvectorise%2FVectType.hs;h=42342c475f8483d560569a4ec2e6b324bd45bf2a;hb=08652e67c4d5d9a40687f93c286021a867c1bca0;hp=0e942ca36135e2bb3561b01cdc4a90246e7229a0;hpb=0e0e3d99dae75cc21e5d5202cdfb57d05a81ee37;p=ghc-hetmet.git

diff --git a/compiler/vectorise/VectType.hs b/compiler/vectorise/VectType.hs
index 0e942ca..42342c4 100644
--- a/compiler/vectorise/VectType.hs
+++ b/compiler/vectorise/VectType.hs
@@ -1,13 +1,7 @@
-{-# OPTIONS -w #-}
--- The above warning supression flag is a temporary kludge.
--- While working on this module you are encouraged to remove it and fix
--- any warnings in the module. See
---     http://hackage.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#Warnings
--- for details
 
 module VectType ( vectTyCon, vectAndLiftType, vectType, vectTypeEnv,
                   mkRepr, arrShapeTys, arrShapeVars, arrSelector,
-                  PAInstance, buildPADict,
+                  buildPADict,
                   fromVect )
 where
 
@@ -25,10 +19,9 @@ import Type
 import TypeRep
 import Coercion
 import FamInstEnv        ( FamInst, mkLocalFamInst )
-import InstEnv           ( Instance, mkLocalInstance, instanceDFunId )
 import OccName
 import MkId
-import BasicTypes        ( StrictnessMark(..), OverlapFlag(..), boolToRecFlag )
+import BasicTypes        ( StrictnessMark(..), boolToRecFlag )
 import Var               ( Var, TyVar )
 import Id                ( mkWildId )
 import Name              ( Name, getOccName )
@@ -39,7 +32,7 @@ import TysPrim           ( intPrimTy )
 import Unique
 import UniqFM
 import UniqSet
-import Util              ( singleton )
+import Util
 import Digraph           ( SCC(..), stronglyConnComp )
 
 import Outputable
@@ -120,13 +113,6 @@ boxType ty = return ty
 
 type TyConGroup = ([TyCon], UniqSet TyCon)
 
-data PAInstance = PAInstance {
-                    painstDFun      :: Var
-                  , painstOrigTyCon :: TyCon
-                  , painstVectTyCon :: TyCon
-                  , painstArrTyCon  :: TyCon
-                  }
-
 vectTypeEnv :: TypeEnv -> VM (TypeEnv, [FamInst], [(Var, CoreExpr)])
 vectTypeEnv env
   = do
@@ -164,19 +150,12 @@ vectTypeEnv env
 
     mk_map env = listToUFM_Directly [(u, getUnique n /= u) | (u,n) <- nameEnvUniqueElts env]
 
-    keep_tc tc = let dcs = tyConDataCons tc
-                 in
-                 defTyCon tc tc >> zipWithM_ defDataCon dcs dcs
-
 
 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
@@ -207,6 +186,7 @@ vectAlgTyConRhs (DataTyCon { data_cons = data_cons
       return $ DataTyCon { data_cons = data_cons'
                          , is_enum   = is_enum
                          }
+vectAlgTyConRhs _ = panic "vectAlgTyConRhs"
 
 vectDataCon :: DataCon -> VM DataCon
 vectDataCon dc
@@ -291,6 +271,7 @@ voidRepr
                , void_bottom = Var var
                }
 
+{-
 enumRepr :: VM Repr
 enumRepr
   = do
@@ -305,6 +286,7 @@ enumRepr
                , enum_arr_tycon    = arr_tycon
                , enum_arr_data_con = arr_data_con
                }
+-}
 
 unboxedProductRepr :: [Type] -> VM Repr
 unboxedProductRepr []   = voidRepr
@@ -406,6 +388,7 @@ replicateSumShape len tag
 arrSelector :: Repr -> [CoreExpr] -> VM (CoreExpr, CoreExpr, CoreExpr)
 arrSelector (SumRepr {})  [len, sel, is] = return (len, sel, is)
 arrSelector (EnumRepr {}) [len, sel, is] = return (len, sel, is)
+arrSelector _             _              = panic "arrSelector"
 
 emptyArrRepr :: Repr -> VM [CoreExpr]
 emptyArrRepr (SumRepr { sum_components = prods })
@@ -418,7 +401,7 @@ emptyArrRepr (IdRepr ty)
   = liftM singleton $ emptyPA ty
 emptyArrRepr (VoidRepr { void_tycon = tycon })
   = liftM singleton $ emptyPA (mkTyConApp tycon [])
-emptyArrRepr (EnumRepr { enum_tycon = tycon })
+emptyArrRepr (EnumRepr {})
   = return []
 
 arrReprTys :: Repr -> VM [Type]
@@ -511,6 +494,8 @@ buildToPRepr repr vect_tc prepr_tc _
     to_unboxed (VoidRepr { void_bottom = bottom })
       = return ([], bottom)
 
+    to_unboxed _ = panic "buildToPRepr/to_unboxed"
+
 
 buildFromPRepr :: Repr -> TyCon -> TyCon -> TyCon -> VM CoreExpr
 buildFromPRepr repr vect_tc prepr_tc _
@@ -571,9 +556,11 @@ buildFromPRepr repr vect_tc prepr_tc _
     from_unboxed (IdRepr _) con expr
        = return $ con `App` expr
 
-    from_unboxed (VoidRepr {}) con expr
+    from_unboxed (VoidRepr {}) con _
        = return con
 
+    from_unboxed _ _ _ = panic "buildFromPRepr/from_unboxed"
+
 buildToArrPRepr :: Repr -> TyCon -> TyCon -> TyCon -> VM CoreExpr
 buildToArrPRepr repr vect_tc prepr_tc arr_tc
   = do
@@ -606,7 +593,7 @@ buildToArrPRepr repr vect_tc prepr_tc arr_tc
 
     [arr_dc] = tyConDataCons arr_tc
 
-    to_repr shape_vars@(len_var : _)
+    to_repr shape_vars@(_ : _)
             repr_vars
             (SumRepr { sum_components   = prods
                      , sum_arr_tycon    = tycon
@@ -637,6 +624,8 @@ buildToArrPRepr repr vect_tc prepr_tc arr_tc
                . mkConApp data_con
                 $ map Var shape_vars
 
+    to_repr _ _ _ = panic "buildToArrPRepr/to_repr"
+
     to_prod repr_vars@(r : _)
             (ProdRepr { prod_components   = tys@(ty : _)
                       , prod_arr_tycon    = tycon
@@ -647,8 +636,9 @@ buildToArrPRepr repr vect_tc prepr_tc arr_tc
                  . mkConApp data_con
                  $ map Type tys ++ len : map Var repr_vars
 
-    to_prod [var] (IdRepr ty)   = return (Var var)
+    to_prod [var] (IdRepr _)    = return (Var var)
     to_prod [var] (VoidRepr {}) = return (Var var)
+    to_prod _     _             = panic "buildToArrPRepr/to_prod"
 
 
 buildFromArrPRepr :: Repr -> TyCon -> TyCon -> TyCon -> VM CoreExpr
@@ -708,13 +698,16 @@ buildFromArrPRepr repr vect_tc prepr_tc arr_tc
 
               from_prod prod (Var var) shape_vars repr_vars res_ty
                 =<< go prods rss vars body
+        go _ _ _ _ = panic "buildFromArrPRepr/go"
 
     from_repr repr expr shape_vars [repr_vars] res_ty body
       = from_prod repr expr shape_vars repr_vars res_ty body
 
-    from_prod prod@(ProdRepr { prod_components = tys
-                             , prod_arr_tycon  = tycon
-                             , prod_arr_data_con = data_con })
+    from_repr _ _ _ _ _ _ = panic "buildFromArrPRepr/from_repr"
+
+    from_prod (ProdRepr { prod_components = tys
+                        , prod_arr_tycon  = tycon
+                        , prod_arr_data_con = data_con })
               expr
               shape_vars
               repr_vars
@@ -723,7 +716,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)]
@@ -741,22 +733,24 @@ buildFromArrPRepr repr vect_tc prepr_tc arr_tc
         return $ Case scrut (mkWildId scrut_ty) res_ty
                  [(DataAlt data_con, shape_vars, body)]
 
-    from_prod (IdRepr ty)
+    from_prod (IdRepr _)
               expr
-              shape_vars
+              _shape_vars
               [repr_var]
-              res_ty
+              _res_ty
               body
       = return $ Let (NonRec repr_var expr) body
 
     from_prod (VoidRepr {})
               expr
-              shape_vars
+              _shape_vars
               [repr_var]
-              res_ty
+              _res_ty
               body
       = return $ Let (NonRec repr_var expr) body
 
+    from_prod _ _ _ _ _ _ = panic "buildFromArrPRepr/from_prod"
+
 buildPRDictRepr :: Repr -> VM CoreExpr
 buildPRDictRepr (VoidRepr { void_tycon = tycon })
   = prDFunOfTyCon tycon
@@ -859,12 +853,6 @@ buildTyConBindings orig_tc vect_tc prepr_tc arr_tc dfun
       dict <- buildPADict repr vect_tc prepr_tc arr_tc dfun
       binds <- takeHoisted
       return $ (dfun, dict) : binds
-  where
-    orig_dcs = tyConDataCons orig_tc
-    vect_dcs = tyConDataCons vect_tc
-    [arr_dc] = tyConDataCons arr_tc
-
-    repr_tys = map dataConRepArgTys vect_dcs
 
 vectDataConWorkers :: Repr -> TyCon -> TyCon -> TyCon
                    -> VM ()
@@ -916,7 +904,7 @@ vectDataConWorkers repr orig_tc vect_tc arr_tc
           units <- replicatePA len (Var unitDataConId)
           return [units]
 
-    mk_arr_repr len arrs = return arrs
+    mk_arr_repr _ arrs = return arrs
 
     def_worker data_con arg_tys mk_body
       = do
@@ -933,7 +921,7 @@ vectDataConWorkers repr orig_tc vect_tc arr_tc
         orig_worker = dataConWorkId data_con
 
 buildPADict :: Repr -> TyCon -> TyCon -> TyCon -> Var -> VM CoreExpr
-buildPADict repr vect_tc prepr_tc arr_tc dfun
+buildPADict repr vect_tc prepr_tc arr_tc _
   = polyAbstract tvs $ \abstract ->
     do
       meth_binds <- mapM (mk_method repr) paMethods
@@ -954,6 +942,7 @@ buildPADict repr vect_tc prepr_tc arr_tc dfun
           var  <- newLocalVar name (exprType body)
           return (var, mkInlineMe body)
 
+paMethods :: [(FastString, Repr -> TyCon -> TyCon -> TyCon -> VM CoreExpr)]
 paMethods = [(fsLit "toPRepr",      buildToPRepr),
              (fsLit "fromPRepr",    buildFromPRepr),
              (fsLit "toArrPRepr",   buildToArrPRepr),
@@ -971,7 +960,7 @@ paMethods = [(fsLit "toPRepr",      buildToPRepr),
 classifyTyCons :: UniqFM Bool -> [TyConGroup] -> ([TyCon], [TyCon])
 classifyTyCons = classify [] []
   where
-    classify conv keep cs [] = (conv, keep)
+    classify conv keep _  [] = (conv, keep)
     classify conv keep cs ((tcs, ds) : rs)
       | can_convert && must_convert
         = classify (tcs ++ conv) keep (cs `addListToUFM` [(tc,True) | tc <- tcs]) rs
@@ -1007,7 +996,7 @@ tyConsOfTyCon
 tyConsOfType :: Type -> UniqSet TyCon
 tyConsOfType ty
   | Just ty' <- coreView ty    = tyConsOfType ty'
-tyConsOfType (TyVarTy v)       = emptyUniqSet
+tyConsOfType (TyVarTy _)       = emptyUniqSet
 tyConsOfType (TyConApp tc tys) = extend (tyConsOfTypes tys)
   where
     extend | isUnLiftedTyCon tc
@@ -1052,7 +1041,7 @@ identityConv (TyConApp tycon tys)
   = do
       mapM_ identityConv tys
       identityConvTyCon tycon
-identityConv ty = noV
+identityConv _ = noV
 
 identityConvTyCon :: TyCon -> VM ()
 identityConvTyCon tc