Make VectType warning-free

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

diff --git a/compiler/vectorise/Vectorise.hs b/compiler/vectorise/Vectorise.hs
index c501163..024ae45 100644 (file)
--- a/compiler/vectorise/Vectorise.hs
+++ b/compiler/vectorise/Vectorise.hs
@@ -8,8 +8,6 @@
 module Vectorise( vectorise )
 where
 
-#include "HsVersions.h"
-
 import VectMonad
 import VectUtils
 import VectType
@@ -70,10 +68,10 @@ vectModule :: ModGuts -> VM ModGuts
 vectModule guts
   = do
       (types', fam_insts, tc_binds) <- vectTypeEnv (mg_types guts)
-      
+
       let fam_inst_env' = extendFamInstEnvList (mg_fam_inst_env guts) fam_insts
       updGEnv (setFamInstEnv fam_inst_env')
-     
+
       -- dicts   <- mapM buildPADict pa_insts
       -- workers <- mapM vectDataConWorkers pa_insts
       binds'  <- mapM vectTopBind (mg_binds guts)
@@ -113,7 +111,7 @@ vectTopBinder var
       var' <- cloneId mkVectOcc var vty
       defGlobalVar var var'
       return var'
-    
+
 vectTopRhs :: Var -> CoreExpr -> VM CoreExpr
 vectTopRhs var expr
   = do
@@ -131,8 +129,7 @@ tryConvert var vect_var rhs
 vectBndr :: Var -> VM VVar
 vectBndr v
   = do
-      vty <- vectType (idType v)
-      lty <- mkPArrayType vty
+      (vty, lty) <- vectAndLiftType (idType v)
       let vv = v `Id.setIdType` vty
           lv = v `Id.setIdType` lty
       updLEnv (mapTo vv lv)
@@ -224,8 +221,8 @@ vectPolyExpr expr
       mono' <- vectExpr mono
       return $ mapVect abstract mono'
   where
-    (tvs, mono) = collectAnnTypeBinders expr  
-                
+    (tvs, mono) = collectAnnTypeBinders expr
+
 vectExpr :: CoreExprWithFVs -> VM VExpr
 vectExpr (_, AnnType ty)
   = liftM vType (vectType ty)
@@ -252,7 +249,7 @@ vectExpr (_, AnnApp (_, AnnVar v) (_, AnnLit lit))
       return (vexpr, lexpr)
   where
     is_special_con con = con `elem` [intDataCon, floatDataCon, doubleDataCon]
-                
+
 
 vectExpr (_, AnnApp fn arg)
   = do
@@ -320,7 +317,7 @@ vectLam fvs bs body
             (vbndrs, vbody) <- vectBndrsIn (vs ++ bs)
                                            (vectExpr body)
             return $ vLams lc vbndrs vbody
-  
+
 vectTyAppExpr :: CoreExprWithFVs -> [Type] -> VM VExpr
 vectTyAppExpr (_, AnnVar v) tys = vectPolyVar v tys
 vectTyAppExpr e tys = pprPanic "vectTyAppExpr" (ppr $ deAnnotate e)
@@ -339,31 +336,28 @@ type CoreAltWithFVs = AnnAlt Id VarSet
 -- When lifting, we have to do it this way because v must have the type
 -- [:V(T):] but the scrutinee must be cast to the representation type. We also
 -- have to handle the case where v is a wild var correctly.
---   
+--
 
 -- FIXME: this is too lazy
 vectAlgCase tycon ty_args scrut bndr ty [(DEFAULT, [], body)]
   = do
-      vscrut <- vectExpr scrut
-      vty    <- vectType ty
-      lty    <- mkPArrayType vty
+      vscrut         <- vectExpr scrut
+      (vty, lty)     <- vectAndLiftType ty
       (vbndr, vbody) <- vectBndrIn bndr (vectExpr body)
       return $ vCaseDEFAULT vscrut vbndr vty lty vbody
 
 vectAlgCase tycon ty_args scrut bndr ty [(DataAlt dc, [], body)]
   = do
-      vscrut <- vectExpr scrut
-      vty    <- vectType ty
-      lty    <- mkPArrayType vty
+      vscrut         <- vectExpr scrut
+      (vty, lty)     <- vectAndLiftType ty
       (vbndr, vbody) <- vectBndrIn bndr (vectExpr body)
       return $ vCaseDEFAULT vscrut vbndr vty lty vbody
 
 vectAlgCase tycon ty_args scrut bndr ty [(DataAlt dc, bndrs, body)]
   = do
-      vect_tc <- maybeV (lookupTyCon tycon)
-      vty <- vectType ty
-      lty <- mkPArrayType vty
-      vexpr <- vectExpr scrut
+      vect_tc    <- maybeV (lookupTyCon tycon)
+      (vty, lty) <- vectAndLiftType ty
+      vexpr      <- vectExpr scrut
       (vbndr, (vbndrs, vbody)) <- vect_scrut_bndr
                                 . vectBndrsIn bndrs
                                 $ vectExpr body
@@ -376,15 +370,13 @@ vectAlgCase tycon ty_args scrut bndr ty [(DataAlt dc, bndrs, body)]
       return . vLet (vNonRec vbndr vexpr)
              $ vCaseProd vscrut vty lty vect_dc arr_dc shape_bndrs vbndrs vbody
   where
-    vect_scrut_bndr | isDeadBinder bndr = vectBndrNewIn bndr FSLIT("scrut")
+    vect_scrut_bndr | isDeadBinder bndr = vectBndrNewIn bndr (fsLit "scrut")
                     | otherwise         = vectBndrIn bndr
 
 vectAlgCase tycon ty_args scrut bndr ty alts
   = do
-      vect_tc <- maybeV (lookupTyCon tycon)
-      vty               <- vectType ty
-      lty               <- mkPArrayType vty
-
+      vect_tc     <- maybeV (lookupTyCon tycon)
+      (vty, lty)  <- vectAndLiftType ty
       repr        <- mkRepr vect_tc
       shape_bndrs <- arrShapeVars repr
       (len, sel, indices) <- arrSelector repr (map Var shape_bndrs)
@@ -410,7 +402,7 @@ vectAlgCase tycon ty_args scrut bndr ty alts
       return . vLet (vNonRec vbndr vexpr)
              $ (vect_case, lift_case)
   where
-    vect_scrut_bndr | isDeadBinder bndr = vectBndrNewIn bndr FSLIT("scrut")
+    vect_scrut_bndr | isDeadBinder bndr = vectBndrNewIn bndr (fsLit "scrut")
                     | otherwise         = vectBndrIn bndr
 
     alts' = sortBy (\(alt1, _, _) (alt2, _, _) -> cmp alt1 alt2) alts
@@ -437,7 +429,7 @@ vectAlgCase tycon ty_args scrut bndr ty alts
           void_tc <- builtin voidTyCon
           let void_ty = mkTyConApp void_tc []
           arr_ty <- mkPArrayType void_ty
-          bndr   <- newLocalVar FSLIT("voids") arr_ty
+          bndr   <- newLocalVar (fsLit "voids") arr_ty
           len    <- lengthPA void_ty (Var bndr)
           e      <- p len
           return ([], [bndr], e)
@@ -461,7 +453,7 @@ packLiftingContext len shape tag fvs vty lty p
   = do
       select <- builtin selectPAIntPrimVar
       let sel_expr = mkApps (Var select) [shape, tag]
-      sel_var <- newLocalVar FSLIT("sel#") (exprType sel_expr)
+      sel_var <- newLocalVar (fsLit "sel#") (exprType sel_expr)
       lc_var <- builtin liftingContext
       localV $
         do
@@ -471,9 +463,8 @@ packLiftingContext len shape tag fvs vty lty p
           (vexpr, lexpr) <- p
           empty <- emptyPA vty
           return (vexpr, Let (NonRec sel_var sel_expr)
-                         . mkLets (concat bnds)
                          $ Case len lc_var lty
-                             [(DEFAULT, [], lexpr),
+                             [(DEFAULT, [], mkLets (concat bnds) lexpr),
                               (LitAlt (mkMachInt 0), [], empty)])
 
 packFreeVar :: CoreExpr -> CoreExpr -> Var -> VM [CoreBind]