Fix vectorisation of nullary data constructors

3 files changed, 75 insertions, 21 deletions

diff --git a/compiler/vectorise/VectBuiltIn.hs b/compiler/vectorise/VectBuiltIn.hs
index 8f23687b10..35b446f383 100644
--- a/compiler/vectorise/VectBuiltIn.hs
+++ b/compiler/vectorise/VectBuiltIn.hs
@@ -46,9 +46,11 @@ data Builtins = Builtins {
                 , prTyCon          :: TyCon
                 , prDataCon        :: DataCon
                 , parrayIntPrimTyCon :: TyCon
+                , voidTyCon        :: TyCon
                 , wrapTyCon        :: TyCon
                 , sumTyCons        :: Array Int TyCon
                 , closureTyCon     :: TyCon
+                , voidVar          :: Var
                 , mkPRVar          :: Var
                 , mkClosureVar     :: Var
                 , applyClosureVar  :: Var
@@ -71,8 +73,9 @@ sumTyCon n bi
 
 prodTyCon :: Int -> Builtins -> TyCon
 prodTyCon n bi
+  | n == 0                      = voidTyCon bi
   | n == 1                      = wrapTyCon bi
-  | n >= 0 && n <= mAX_NDP_PROD = tupleTyCon Boxed n
+  | n >= 2 && n <= mAX_NDP_PROD = tupleTyCon Boxed n
   | otherwise = pprPanic "prodTyCon" (ppr n)
 
 initBuiltins :: DsM Builtins
@@ -87,12 +90,14 @@ initBuiltins
       parrayIntPrimTyCon <- dsLookupTyCon parrayIntPrimTyConName
       closureTyCon <- dsLookupTyCon closureTyConName
 
+      voidTyCon    <- lookupExternalTyCon nDP_REPR FSLIT("Void")
       wrapTyCon    <- lookupExternalTyCon nDP_REPR FSLIT("Wrap")
       sum_tcs <- mapM (lookupExternalTyCon nDP_REPR)
                       [mkFastString ("Sum" ++ show i) | i <- [2..mAX_NDP_SUM]]
 
       let sumTyCons = listArray (2, mAX_NDP_SUM) sum_tcs
 
+      voidVar          <- lookupExternalVar nDP_REPR FSLIT("void")
       mkPRVar          <- dsLookupGlobalId mkPRName
       mkClosureVar     <- dsLookupGlobalId mkClosureName
       applyClosureVar  <- dsLookupGlobalId applyClosureName
@@ -117,9 +122,11 @@ initBuiltins
                , prTyCon          = prTyCon
                , prDataCon        = prDataCon
                , parrayIntPrimTyCon = parrayIntPrimTyCon
+               , voidTyCon        = voidTyCon
                , wrapTyCon        = wrapTyCon
                , sumTyCons        = sumTyCons
                , closureTyCon     = closureTyCon
+               , voidVar          = voidVar
                , mkPRVar          = mkPRVar
                , mkClosureVar     = mkClosureVar
                , applyClosureVar  = applyClosureVar
@@ -154,16 +161,18 @@ initBuiltinDicts ps
   where
     (tcs, mods, fss) = unzip3 ps
 
-initBuiltinPAs = initBuiltinDicts builtinPAs
+initBuiltinPAs = initBuiltinDicts . builtinPAs
 
-builtinPAs :: [(Name, Module, FastString)]
-builtinPAs = [
-               mk closureTyConName  nDP_CLOSURE   FSLIT("dPA_Clo")
-             , mk unitTyConName     nDP_INSTANCES FSLIT("dPA_Unit")
+builtinPAs :: Builtins -> [(Name, Module, FastString)]
+builtinPAs bi
+  = [
+      mk closureTyConName  nDP_CLOSURE       FSLIT("dPA_Clo")
+    , mk (tyConName $ voidTyCon bi) nDP_REPR FSLIT("dPA_Void")
+    , mk unitTyConName     nDP_INSTANCES     FSLIT("dPA_Unit")
 
-             , mk intTyConName      nDP_INSTANCES FSLIT("dPA_Int")
-             ]
-             ++ tups
+    , mk intTyConName      nDP_INSTANCES FSLIT("dPA_Int")
+    ]
+    ++ tups
   where
     mk name mod fs = (name, mod, fs)
 
@@ -178,6 +187,7 @@ builtinPRs :: Builtins -> [(Name, Module, FastString)]
 builtinPRs bi =
   [
     mk (tyConName unitTyCon) nDP_REPR      FSLIT("dPR_Unit")
+  , mk (tyConName $ voidTyCon bi) nDP_REPR FSLIT("dPR_Void")
   , mk (tyConName $ wrapTyCon bi) nDP_REPR FSLIT("dPR_Wrap")
   , mk closureTyConName      nDP_CLOSURE   FSLIT("dPR_Clo")
 
diff --git a/compiler/vectorise/VectMonad.hs b/compiler/vectorise/VectMonad.hs
index b60a67c7ac..cf71a00e55 100644
--- a/compiler/vectorise/VectMonad.hs
+++ b/compiler/vectorise/VectMonad.hs
@@ -463,7 +463,7 @@ initV hsc_env guts info p
       do
         builtins       <- initBuiltins
         builtin_tycons <- initBuiltinTyCons
-        builtin_pas    <- initBuiltinPAs
+        builtin_pas    <- initBuiltinPAs builtins
         builtin_prs    <- initBuiltinPRs builtins
 
         eps <- ioToIOEnv $ hscEPS hsc_env
diff --git a/compiler/vectorise/VectType.hs b/compiler/vectorise/VectType.hs
index 4ff1711320..ca5f0c8279 100644
--- a/compiler/vectorise/VectType.hs
+++ b/compiler/vectorise/VectType.hs
@@ -226,6 +226,20 @@ data Repr = ProdRepr {
 
           | IdRepr Type
 
+          | VoidRepr {
+              void_tycon        :: TyCon
+            , void_bottom       :: CoreExpr
+            }
+
+mkVoid :: VM Repr
+mkVoid = do
+           tycon <- builtin voidTyCon
+           var   <- builtin voidVar
+           return $ VoidRepr {
+                      void_tycon  = tycon
+                    , void_bottom = Var var
+                    }
+
 mkProduct :: [Type] -> VM Repr
 mkProduct tys
   = do
@@ -246,6 +260,7 @@ mkProduct tys
     arity = length tys
 
 mkSubProduct :: [Type] -> VM Repr
+mkSubProduct []   = mkVoid
 mkSubProduct [ty] = return $ IdRepr ty
 mkSubProduct tys  = mkProduct tys
 
@@ -275,6 +290,7 @@ reprType (ProdRepr { prod_tycon = tycon, prod_components = tys })
 reprType (SumRepr { sum_tycon = tycon, sum_components = reprs })
   = mkTyConApp tycon (map reprType reprs)
 reprType (IdRepr ty) = ty
+reprType (VoidRepr { void_tycon = tycon }) = mkTyConApp tycon []
 
 arrReprType :: Repr -> VM Type
 arrReprType = mkPArrayType . reprType
@@ -286,6 +302,7 @@ arrShapeTys (SumRepr  {})
       return [intPrimTy, mkTyConApp int_arr [], mkTyConApp int_arr []]
 arrShapeTys (ProdRepr {}) = return [intPrimTy]
 arrShapeTys (IdRepr _)    = return []
+arrShapeTys (VoidRepr {}) = return [intPrimTy]
 
 arrShapeVars :: Repr -> VM [Var]
 arrShapeVars repr = mapM (newLocalVar FSLIT("sh")) =<< arrShapeTys repr
@@ -298,22 +315,31 @@ replicateShape (SumRepr {})  len tag
       up  <- builtin upToPAIntPrimVar
       return [len, Var rep `mkApps` [len, tag], Var up `App` len]
 replicateShape (IdRepr _) _ _ = return []
+replicateShape (VoidRepr {}) len _ = return [len]
 
-arrReprElemTys :: Repr -> [[Type]]
+arrReprElemTys :: Repr -> VM [[Type]]
 arrReprElemTys (SumRepr { sum_components = prods })
-  = map arrProdElemTys prods
+  = mapM arrProdElemTys prods
 arrReprElemTys prod@(ProdRepr {})
-  = [arrProdElemTys prod]
-arrReprElemTys (IdRepr ty) = [[ty]]
+  = do
+      tys <- arrProdElemTys prod
+      return [tys]
+arrReprElemTys (IdRepr ty) = return [[ty]]
+arrReprElemTys (VoidRepr { void_tycon = tycon })
+  = return [[mkTyConApp tycon []]]
 
 arrProdElemTys (ProdRepr { prod_components = [] })
-  = [unitTy]
+  = do
+      void <- builtin voidTyCon
+      return [mkTyConApp void []]
 arrProdElemTys (ProdRepr { prod_components = tys })
-  = tys
-arrProdElemTys (IdRepr ty) = [ty]
+  = return tys
+arrProdElemTys (IdRepr ty) = return [ty]
+arrProdElemTys (VoidRepr { void_tycon = tycon })
+  = return [mkTyConApp tycon []]
 
 arrReprTys :: Repr -> VM [[Type]]
-arrReprTys = mapM (mapM mkPArrayType) . arrReprElemTys
+arrReprTys repr = mapM (mapM mkPArrayType) =<< arrReprElemTys repr
 
 arrReprVars :: Repr -> VM [[Var]]
 arrReprVars repr
@@ -376,6 +402,10 @@ buildToPRepr repr vect_tc prepr_tc _
           var <- newLocalVar FSLIT("y") ty
           return ([var], Var var)
 
+    prod_alt (VoidRepr { void_bottom = bottom })
+      = return ([], bottom)
+
+
 buildFromPRepr :: Repr -> TyCon -> TyCon -> TyCon -> VM CoreExpr
 buildFromPRepr repr vect_tc prepr_tc _
   = do
@@ -418,6 +448,9 @@ buildFromPRepr repr vect_tc prepr_tc _
     from_prod (IdRepr _) con expr
        = return $ con `App` expr
 
+    from_prod (VoidRepr {}) con expr
+       = return con
+
 buildToArrPRepr :: Repr -> TyCon -> TyCon -> TyCon -> VM CoreExpr
 buildToArrPRepr repr vect_tc prepr_tc arr_tc
   = do
@@ -483,8 +516,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 ty)   = return (Var var)
+    to_prod [var] (VoidRepr {}) = return (Var var)
+
 
 buildFromArrPRepr :: Repr -> TyCon -> TyCon -> TyCon -> VM CoreExpr
 buildFromArrPRepr repr vect_tc prepr_tc arr_tc
@@ -571,7 +605,17 @@ buildFromArrPRepr repr vect_tc prepr_tc arr_tc
               body
       = return $ Let (NonRec repr_var expr) body
 
+    from_prod (VoidRepr {})
+              expr
+              shape_vars
+              [repr_var]
+              res_ty
+              body
+      = return $ Let (NonRec repr_var expr) body
+
 buildPRDictRepr :: Repr -> VM CoreExpr
+buildPRDictRepr (VoidRepr { void_tycon = tycon })
+  = prDFunOfTyCon tycon
 buildPRDictRepr (IdRepr ty) = mkPR ty
 buildPRDictRepr (ProdRepr {
                    prod_components = tys
@@ -679,6 +723,7 @@ vectDataConWorkers :: Repr -> TyCon -> TyCon -> TyCon
                    -> VM ()
 vectDataConWorkers repr orig_tc vect_tc arr_tc
   = do
+      arr_tys <- arrReprElemTys repr
       bs <- sequence
           . zipWith3 def_worker  (tyConDataCons orig_tc) rep_tys
           $ zipWith4 mk_data_con (tyConDataCons vect_tc)
@@ -694,7 +739,6 @@ vectDataConWorkers repr orig_tc vect_tc arr_tc
     res_ty   = mkTyConApp vect_tc var_tys
 
     rep_tys  = map dataConRepArgTys $ tyConDataCons vect_tc
-    arr_tys  = arrReprElemTys repr
 
     [arr_dc] = tyConDataCons arr_tc