Fix newtype wrapper for 'PData[s] (Wrap a)' and fix VECTORISE type and instance pragmas

* Correct usage of new type wrappers from MkId
* 'VECTORISE [SCALAR] type T = S' didn't work correctly across module boundaries
* Clean up 'VECTORISE SCALAR instance'

compiler/coreSyn/CoreFVs.lhs

@@ -333,7 +333,7 @@ vectsFreeVars = foldr (unionVarSet . vectFreeVars) emptyVarSet
     vectFreeVars (NoVect _)            = noFVs
     vectFreeVars (VectType _ _ _)      = noFVs
     vectFreeVars (VectClass _)         = noFVs
-    vectFreeVars (VectInst _ _)        = noFVs
+    vectFreeVars (VectInst _)          = noFVs
       -- this function is only concerned with values, not types
 \end{code}
 

compiler/coreSyn/CoreSubst.lhs

@@ -754,7 +754,7 @@ substVect subst  (Vect   v (Just rhs)) = Vect v (Just (simpleOptExprWith subst r
 substVect _subst vd@(NoVect _)         = vd
 substVect _subst vd@(VectType _ _ _)   = vd
 substVect _subst vd@(VectClass _)      = vd
-substVect _subst vd@(VectInst _ _)     = vd
+substVect _subst vd@(VectInst _)       = vd
 
 ------------------
 substVarSet :: Subst -> VarSet -> VarSet

compiler/coreSyn/CoreSyn.lhs

@@ -538,7 +538,7 @@ data CoreVect = Vect      Id   (Maybe CoreExpr)
               | NoVect    Id
               | VectType  Bool TyCon (Maybe TyCon)
               | VectClass TyCon                     -- class tycon
-              | VectInst  Bool Id                   -- (1) whether SCALAR & (2) instance dfun
+              | VectInst  Id                        -- instance dfun (always SCALAR)
 \end{code}
 
 

compiler/coreSyn/PprCore.lhs

@@ -510,6 +510,5 @@ instance Outputable CoreVect where
   ppr (VectType True var (Just tc))  = ptext (sLit "VECTORISE SCALAR type") <+> ppr var <+>
                                        char '=' <+> ppr tc
   ppr (VectClass tc)                 = ptext (sLit "VECTORISE class") <+> ppr tc
-  ppr (VectInst False var)           = ptext (sLit "VECTORISE instance") <+> ppr var
-  ppr (VectInst True var)            = ptext (sLit "VECTORISE SCALAR instance") <+> ppr var
+  ppr (VectInst var)                 = ptext (sLit "VECTORISE SCALAR instance") <+> ppr var
 \end{code}

compiler/deSugar/Desugar.lhs

@@ -23,6 +23,7 @@ import TcRnTypes
 import MkIface
 import Id
 import Name
+import Type
 import InstEnv
 import Class
 import Avail
@@ -415,15 +416,19 @@ dsVect (L loc (HsVect (L _ v) rhs))
 dsVect (L _loc (HsNoVect (L _ v)))
   = return $ NoVect v
 dsVect (L _loc (HsVectTypeOut isScalar tycon rhs_tycon))
-  = return $ VectType isScalar tycon rhs_tycon
+  = return $ VectType isScalar tycon' rhs_tycon
+  where
+    tycon' | Just ty <- coreView $ mkTyConTy tycon
+           , (tycon', []) <- splitTyConApp ty      = tycon'
+           | otherwise                             = tycon
 dsVect vd@(L _ (HsVectTypeIn _ _ _))
   = pprPanic "Desugar.dsVect: unexpected 'HsVectTypeIn'" (ppr vd)
 dsVect (L _loc (HsVectClassOut cls))
   = return $ VectClass (classTyCon cls)
 dsVect vc@(L _ (HsVectClassIn _))
   = pprPanic "Desugar.dsVect: unexpected 'HsVectClassIn'" (ppr vc)
-dsVect (L _loc (HsVectInstOut isScalar inst))
-  = return $ VectInst isScalar (instanceDFunId inst)
-dsVect vi@(L _ (HsVectInstIn _ _))
+dsVect (L _loc (HsVectInstOut inst))
+  = return $ VectInst (instanceDFunId inst)
+dsVect vi@(L _ (HsVectInstIn _))
   = pprPanic "Desugar.dsVect: unexpected 'HsVectInstIn'" (ppr vi)
 \end{code}

compiler/hsSyn/HsDecls.lhs

@@ -1093,11 +1093,9 @@ data VectDecl name
       (Located name)
   | HsVectClassOut              -- post type-checking
       Class
-  | HsVectInstIn                -- pre type-checking
-      Bool                      -- 'TRUE' => SCALAR declaration
+  | HsVectInstIn                -- pre type-checking (always SCALAR)
       (LHsType name)
-  | HsVectInstOut               -- post type-checking
-      Bool                      -- 'TRUE' => SCALAR declaration
+  | HsVectInstOut               -- post type-checking (always SCALAR)
       Instance
   deriving (Data, Typeable)
 
@@ -1108,15 +1106,13 @@ lvectDeclName (L _ (HsVectTypeIn   _ (L _ name) _)) = getName name
 lvectDeclName (L _ (HsVectTypeOut  _ tycon _))      = getName tycon
 lvectDeclName (L _ (HsVectClassIn  (L _ name)))     = getName name
 lvectDeclName (L _ (HsVectClassOut cls))            = getName cls
-lvectDeclName (L _ (HsVectInstIn   _ _))            = panic "HsDecls.lvectDeclName: HsVectInstIn"
-lvectDeclName (L _ (HsVectInstOut  _ _))            = panic "HsDecls.lvectDeclName: HsVectInstOut"
--- lvectDeclName (L _ (HsVectInstIn   _ (L _ name)))   = getName name
--- lvectDeclName (L _ (HsVectInstOut  _ inst))         = getName inst
+lvectDeclName (L _ (HsVectInstIn   _))              = panic "HsDecls.lvectDeclName: HsVectInstIn"
+lvectDeclName (L _ (HsVectInstOut  _))              = panic "HsDecls.lvectDeclName: HsVectInstOut"
 
 lvectInstDecl :: LVectDecl name -> Bool
-lvectInstDecl (L _ (HsVectInstIn _ _))  = True
-lvectInstDecl (L _ (HsVectInstOut _ _)) = True
-lvectInstDecl _                         = False
+lvectInstDecl (L _ (HsVectInstIn _))  = True
+lvectInstDecl (L _ (HsVectInstOut _)) = True
+lvectInstDecl _                       = False
 
 instance OutputableBndr name => Outputable (VectDecl name) where
   ppr (HsVect v Nothing)
@@ -1147,13 +1143,9 @@ instance OutputableBndr name => Outputable (VectDecl name) where
     = sep [text "{-# VECTORISE class" <+> ppr c <+> text "#-}" ]
   ppr (HsVectClassOut c)
     = sep [text "{-# VECTORISE class" <+> ppr c <+> text "#-}" ]
-  ppr (HsVectInstIn False ty)
-    = sep [text "{-# VECTORISE instance" <+> ppr ty <+> text "#-}" ]
-  ppr (HsVectInstIn True ty)
+  ppr (HsVectInstIn ty)
     = sep [text "{-# VECTORISE SCALAR instance" <+> ppr ty <+> text "#-}" ]
-  ppr (HsVectInstOut False i)
-    = sep [text "{-# VECTORISE instance" <+> ppr i <+> text "#-}" ]
-  ppr (HsVectInstOut True i)
+  ppr (HsVectInstOut i)
     = sep [text "{-# VECTORISE SCALAR instance" <+> ppr i <+> text "#-}" ]
 \end{code}
 

compiler/iface/TcIface.lhs

@@ -728,10 +728,11 @@ tcIfaceVectInfo mod typeEnv (IfaceVectInfo
                              , ifaceVectInfoScalarTyCons = scalarTyCons
                              })
   = do { let scalarTyConsSet = mkNameSet scalarTyCons
-       ; vVars       <- mapM vectVarMapping                          vars
-       ; tyConRes1   <- mapM vectTyConMapping                        tycons
-       ; tyConRes2   <- mapM (vectTyConReuseMapping scalarTyConsSet) tyconsReuse
-       ; vScalarVars <- mapM vectVar                                 scalarVars
+       ; vVars       <- mapM vectVarMapping                  vars
+       ; let varsSet = mkVarSet (map fst vVars)
+       ; tyConRes1   <- mapM (vectTyConVectMapping varsSet)  tycons
+       ; tyConRes2   <- mapM (vectTyConReuseMapping varsSet) tyconsReuse
+       ; vScalarVars <- mapM vectVar                         scalarVars
        ; let (vTyCons, vDataCons) = unzip (tyConRes1 ++ tyConRes2)
        ; return $ VectInfo 
                   { vectInfoVar          = mkVarEnv  vVars
@@ -757,69 +758,51 @@ tcIfaceVectInfo mod typeEnv (IfaceVectInfo
       = forkM (ptext (sLit "vect scalar var")  <+> ppr name)  $
           tcIfaceExtId name
 
-    vectTyConMapping name 
+    vectTyConVectMapping vars name
       = do { vName  <- lookupOrig mod (mkLocalisedOccName mod mkVectTyConOcc name)
+           ; vectTyConMapping vars name vName
+           }
+
+    vectTyConReuseMapping vars name
+      = vectTyConMapping vars name name
+
+    vectTyConMapping vars name vName
+      = do { tycon  <- lookupLocalOrExternal name
+           ; vTycon <- lookupLocalOrExternal vName
+
+               -- map the data constructors of the original type constructor to those of the
+               -- vectorised type constructor /unless/ the type constructor was vectorised
+               -- abstractly; if it was vectorised abstractly, the workers of its data constructors
+               -- do not appear in the set of vectorised variables
+           ; let isAbstract | isClassTyCon tycon = False
+                            | datacon:_ <- tyConDataCons tycon 
+                                                 = not $ dataConWrapId datacon `elemVarSet` vars
+                            | otherwise          = True
+                 vDataCons  | isAbstract = []
+                            | otherwise  = [ (dataConName datacon, (datacon, vDatacon))
+                                           | (datacon, vDatacon) <- zip (tyConDataCons tycon)
+                                                                        (tyConDataCons vTycon)
+                                           ]
 
-               -- we need a fully defined version of the type constructor to be able to extract
-               -- its data constructors etc.
-           ; tycon  <- do { let mb_tycon = lookupTypeEnv typeEnv name
-                          ; case mb_tycon of
-                                -- tycon is local
-                              Just (ATyCon tycon) -> return tycon
-                                -- name is not a tycon => internal inconsistency
-                              Just _              -> notATyConErr
-                                -- tycon is external
-                              Nothing             -> tcIfaceTyCon (IfaceTc name)
-                          }
-           ; vTycon <- forkM (text ("vect vTycon") <+> ppr vName) $
-                         tcIfaceTyCon (IfaceTc vName)
-
-               -- we need to handle class type constructors differently due to the manner in which
-               -- the name for the dictionary data constructor is computed
-           ; vDataCons <- if isClassTyCon tycon
-                          then vectClassDataConMapping vName (tyConSingleDataCon_maybe tycon)
-                          else mapM vectDataConMapping (tyConDataCons tycon)
            ; return ( (name, (tycon, vTycon))          -- (T, T_v)
                     , vDataCons                        -- list of (Ci, Ci_v)
                     )
            }
       where
-        notATyConErr = pprPanic "TcIface.tcIfaceVectInfo: not a tycon" (ppr name)
-
-    vectTyConReuseMapping scalarNames name 
-      = do { tycon <- forkM (text ("vect reuse tycon") <+> ppr name) $
-                        tcIfaceTyCon (IfaceTc name) -- somewhat naughty for wired in tycons, but ok
-           ; if name `elemNameSet` scalarNames
-             then do
-           { return ( (name, (tycon, tycon))      -- scalar type constructors expose no data..
-                    , []                          -- ..constructors see..
-                    )                             -- .."Note [Pragmas to vectorise tycons]"..
-                                                  -- ..in 'Vectorise.Type.Env'
-           } else do 
-           { let { vDataCons  = [ (dataConName dc, (dc, dc)) 
-                                | dc <- tyConDataCons tycon]
-                 }
-           ; return ( (name, (tycon, tycon))          -- (T, T)
-                    , vDataCons                       -- list of (Ci, Ci)
-                    )
-           }}
-
-    vectClassDataConMapping _vTyconName Nothing = panic "tcIfaceVectInfo: vectClassDataConMapping"
-    vectClassDataConMapping vTyconName  (Just datacon)
-      = do { let name = dataConName datacon
-           ; vName <- lookupOrig mod (mkClassDataConOcc . nameOccName $ vTyconName)
-           ; vDataCon <- forkM (text ("vect class datacon") <+> ppr name) $
-                           tcIfaceDataCon vName
-           ; return [(name, (datacon, vDataCon))]
-           }
+          -- we need a fully defined version of the type constructor to be able to extract
+          -- its data constructors etc.
+        lookupLocalOrExternal name
+          = do { let mb_tycon = lookupTypeEnv typeEnv name
+               ; case mb_tycon of
+                     -- tycon is local
+                   Just (ATyCon tycon) -> return tycon
+                     -- name is not a tycon => internal inconsistency
+                   Just _              -> notATyConErr
+                     -- tycon is external
+                   Nothing             -> tcIfaceTyCon (IfaceTc name)
+               }
 
-    vectDataConMapping datacon
-      = do { let name = dataConName datacon
-           ; vName <- lookupOrig mod (mkLocalisedOccName mod mkVectDataConOcc name)
-           ; vDataCon <- forkM (text ("vect datacon") <+> ppr name) $
-                           tcIfaceDataCon vName
-           ; return (name, (datacon, vDataCon))
-           }
+        notATyConErr = pprPanic "TcIface.tcIfaceVectInfo: not a tycon" (ppr name)
 \end{code}
 
 %************************************************************************

compiler/main/HscTypes.lhs

@@ -1948,6 +1948,9 @@ data VectInfo
 --
 -- NB: The field 'ifaceVectInfoVar' explicitly contains the workers of data constructors as well as
 --     class selectors — i.e., their mappings are /not/ implicitly generated from the data types.
+--     Moreover, whether the worker of a data constructor is in 'ifaceVectInfoVar' determines
+--     whether that data constructor was vectorised (or is part of an abstractly vectorised type
+--     constructor).
 --
 data IfaceVectInfo
   = IfaceVectInfo

compiler/parser/Parser.y.pp

@@ -589,11 +589,12 @@ topdecl :: { OrdList (LHsDecl RdrName) }
         | '{-# VECTORISE' 'type' gtycon '=' gtycon '#-}'     
                                                 { unitOL $ LL $ 
                                                     VectD (HsVectTypeIn False $3 (Just $5)) }
+        | '{-# VECTORISE_SCALAR' 'type' gtycon '=' gtycon '#-}'     
+                                                { unitOL $ LL $ 
+                                                    VectD (HsVectTypeIn True $3 (Just $5)) }
         | '{-# VECTORISE' 'class' gtycon '#-}'  { unitOL $ LL $ VectD (HsVectClassIn $3) }
-        | '{-# VECTORISE' 'instance' type '#-}'     
-                                                { unitOL $ LL $ VectD (HsVectInstIn False $3) }
         | '{-# VECTORISE_SCALAR' 'instance' type '#-}'     
-                                                { unitOL $ LL $ VectD (HsVectInstIn True $3) }
+                                                { unitOL $ LL $ VectD (HsVectInstIn $3) }
         | annotation { unitOL $1 }
         | decl                                  { unLoc $1 }
 

compiler/rename/RnSource.lhs

@@ -672,11 +672,11 @@ rnHsVectDecl (HsVectClassIn cls)
        }
 rnHsVectDecl (HsVectClassOut _)
   = panic "RnSource.rnHsVectDecl: Unexpected 'HsVectClassOut'"
-rnHsVectDecl (HsVectInstIn isScalar instTy)
+rnHsVectDecl (HsVectInstIn instTy)
   = do { instTy' <- rnLHsInstType (text "In a VECTORISE pragma") instTy
-       ; return (HsVectInstIn isScalar instTy', emptyFVs)
+       ; return (HsVectInstIn instTy', emptyFVs)
        }
-rnHsVectDecl (HsVectInstOut _ _)
+rnHsVectDecl (HsVectInstOut _)
   = panic "RnSource.rnHsVectDecl: Unexpected 'HsVectInstOut'"
 \end{code}
 

compiler/typecheck/TcBinds.lhs

@@ -694,7 +694,11 @@ tcVect (HsNoVect name)
 tcVect (HsVectTypeIn isScalar lname rhs_name)
   = addErrCtxt (vectCtxt lname) $
     do { tycon <- tcLookupLocatedTyCon lname
-       ; checkTc (not isScalar || tyConArity tycon == 0) scalarTyConMustBeNullary
+       ; checkTc (   not isScalar             -- either    we have a non-SCALAR declaration
+                 || isJust rhs_name           -- or        we explicitly provide a vectorised type
+                 || tyConArity tycon == 0     -- otherwise the type constructor must be nullary
+                 )
+                 scalarTyConMustBeNullary
 
        ; rhs_tycon <- fmapMaybeM (tcLookupTyCon . unLoc) rhs_name
        ; return $ HsVectTypeOut isScalar tycon rhs_tycon
@@ -708,13 +712,13 @@ tcVect (HsVectClassIn lname)
        }
 tcVect (HsVectClassOut _)
   = panic "TcBinds.tcVect: Unexpected 'HsVectClassOut'"
-tcVect (HsVectInstIn isScalar linstTy)
+tcVect (HsVectInstIn linstTy)
   = addErrCtxt (vectCtxt linstTy) $
     do { (cls, tys) <- tcHsVectInst linstTy
        ; inst       <- tcLookupInstance cls tys
-       ; return $ HsVectInstOut isScalar inst
+       ; return $ HsVectInstOut inst
        }
-tcVect (HsVectInstOut _ _)
+tcVect (HsVectInstOut _)
   = panic "TcBinds.tcVect: Unexpected 'HsVectInstOut'"
 
 vectCtxt :: Outputable thing => thing -> SDoc

compiler/typecheck/TcHsSyn.lhs

@@ -1063,9 +1063,9 @@ zonkVect _ (HsVectTypeIn _ _ _) = panic "TcHsSyn.zonkVect: HsVectTypeIn"
 zonkVect _env (HsVectClassOut c)
   = return $ HsVectClassOut c
 zonkVect _ (HsVectClassIn _) = panic "TcHsSyn.zonkVect: HsVectClassIn"
-zonkVect _env (HsVectInstOut s i)
-  = return $ HsVectInstOut s i
-zonkVect _ (HsVectInstIn _ _) = panic "TcHsSyn.zonkVect: HsVectInstIn"
+zonkVect _env (HsVectInstOut i)
+  = return $ HsVectInstOut i
+zonkVect _ (HsVectInstIn _) = panic "TcHsSyn.zonkVect: HsVectInstIn"
 \end{code}
 
 %************************************************************************

compiler/vectorise/Vectorise.hs

@@ -87,8 +87,8 @@ vectModule guts@(ModGuts { mg_tcs        = tycons
 
           -- Vectorise all the top level bindings and VECTORISE declarations on imported identifiers
           -- NB: Need to vectorise the imported bindings first (local bindings may depend on them).
-      ; let impBinds = [imp_id | Vect          imp_id _ <- vect_decls, isGlobalId imp_id] ++
-                       [imp_id | VectInst True imp_id   <- vect_decls, isGlobalId imp_id]
+      ; let impBinds = [imp_id | Vect     imp_id _ <- vect_decls, isGlobalId imp_id] ++
+                       [imp_id | VectInst imp_id   <- vect_decls, isGlobalId imp_id]
       ; binds_imp <- mapM vectImpBind impBinds
       ; binds_top <- mapM vectTopBind binds
 
@@ -150,7 +150,7 @@ vectTopBind b@(NonRec var expr)
          ; (inline, isScalar, expr') <- vectTopRhs [] var expr
          ; var' <- vectTopBinder var inline expr'
          ; when isScalar $ 
-             addGlobalScalar var
+             addGlobalScalarVar var
  
              -- We replace the original top-level binding by a value projected from the vectorised
              -- closure and add any newly created hoisted top-level bindings.
@@ -182,7 +182,7 @@ vectTopBind b@(Rec bs)
                   ; if and areScalars
                     then      -- (1) Entire recursive group is scalar
                               --      => add all variables to the global set of scalars
-                         do { mapM_ addGlobalScalar vars
+                         do { mapM_ addGlobalScalarVar vars
                             ; return (vars', inlines, exprs', hs)
                             }
                     else      -- (2) At least one binding is not scalar
@@ -226,7 +226,7 @@ vectImpBind var
        ; (inline, isScalar, expr') <- vectTopRhs [] var (Var var)
        ; var' <- vectTopBinder var inline expr'
        ; when isScalar $ 
-           addGlobalScalar var
+           addGlobalScalarVar var
 
            -- We add any newly created hoisted top-level bindings.
        ; hs <- takeHoisted
@@ -340,7 +340,7 @@ vectTopRhs :: [Var]           -- ^ Names of all functions in the rec block
                  , CoreExpr)  -- (3) the vectorised right-hand side
 vectTopRhs recFs var expr
   = closedV
-  $ do { globalScalar <- isGlobalScalar var
+  $ do { globalScalar <- isGlobalScalarVar var
        ; vectDecl     <- lookupVectDecl var
        ; let isDFun = isDFunId var
 
@@ -385,7 +385,7 @@ tryConvert :: Var       -- ^ Name of the original binding (eg @foo@)
            -> CoreExpr  -- ^ The original body of the binding.
            -> VM CoreExpr
 tryConvert var vect_var rhs
-  = do { globalScalar <- isGlobalScalar var
+  = do { globalScalar <- isGlobalScalarVar var
        ; if globalScalar
          then
            return rhs

compiler/vectorise/Vectorise/Env.hs

@@ -129,6 +129,10 @@ data GlobalEnv
 
 -- |Create an initial global environment.
 --
+-- We add scalar variables and type constructors identified by vectorisation pragmas already here
+-- to the global table, so that we can query scalarness during vectorisation, and especially, when
+-- vectorising the scalar entities' definitions themselves.
+--
 initGlobalEnv :: VectInfo -> [CoreVect] -> (InstEnv, InstEnv) -> FamInstEnvs -> GlobalEnv
 initGlobalEnv info vectDecls instEnvs famInstEnvs
   = GlobalEnv 
@@ -151,10 +155,16 @@ initGlobalEnv info vectDecls instEnvs famInstEnvs
                                         -- FIXME: we currently only allow RHSes consisting of a
                                         --   single variable to be able to obtain the type without
                                         --   inference — see also 'TcBinds.tcVect'
-    scalar_vars   = [var              | Vect     var   Nothing                  <- vectDecls] ++
-                    [var              | VectInst True var                       <- vectDecls]
-    novects       = [var              | NoVect   var                            <- vectDecls]
-    scalar_tycons = [tyConName tycon  | VectType True tycon _                   <- vectDecls]
+    scalar_vars   = [var              | Vect     var   Nothing                   <- vectDecls] ++
+                    [var              | VectInst var                             <- vectDecls]
+    novects       = [var              | NoVect   var                             <- vectDecls]
+    scalar_tycons = [tyConName tycon  | VectType True tycon Nothing              <- vectDecls] ++
+                    [tyConName tycon  | VectType _    tycon (Just tycon')        <- vectDecls
+                                      , tycon == tycon']
+                      -- - for 'VectType True tycon Nothing', we checked that the type does not
+                      --   contain arrays (or type variables that could be instatiated to arrays)
+                      -- - for 'VectType _ tycon (Just tycon')', where the two tycons are the same,
+                      --   we also know that there can be no embedded arrays
 
 
 -- Operators on Global Environments -------------------------------------------
@@ -207,7 +217,7 @@ modVectInfo env mg_ids mg_tyCons vectDecls info
     }
   where
     vectIds         = [id    | Vect     id    _   <- vectDecls] ++
-                      [id    | VectInst _ id      <- vectDecls]
+                      [id    | VectInst id        <- vectDecls]
     vectTypeTyCons  = [tycon | VectType _ tycon _ <- vectDecls] ++
                       [tycon | VectClass tycon    <- vectDecls]
     vectDataCons    = concatMap tyConDataCons vectTypeTyCons

compiler/vectorise/Vectorise/Monad.hs

@@ -14,7 +14,8 @@ module Vectorise.Monad (
   -- * Variables
   lookupVar,
   lookupVar_maybe,
-  addGlobalScalar, 
+  addGlobalScalarVar, 
+  addGlobalScalarTyCon, 
 ) where
 
 import Vectorise.Monad.Base
@@ -32,6 +33,8 @@ import DynFlags
 import MonadUtils (liftIO)
 import InstEnv
 import Class
+import TyCon
+import NameSet
 import VarSet
 import VarEnv
 import Var
@@ -174,8 +177,17 @@ dumpVar var
 -- |Mark the given variable as scalar — i.e., executing the associated code does not involve any
 -- parallel array computations.
 --
-addGlobalScalar :: Var -> VM ()
-addGlobalScalar var
-  = do { traceVt "addGlobalScalar" (ppr var)
+addGlobalScalarVar :: Var -> VM ()
+addGlobalScalarVar var
+  = do { traceVt "addGlobalScalarVar" (ppr var)
        ; updGEnv $ \env -> env{global_scalar_vars = extendVarSet (global_scalar_vars env) var}
        }
+
+-- |Mark the given type constructor as scalar — i.e., its values cannot embed parallel arrays.
+--
+addGlobalScalarTyCon :: TyCon -> VM ()
+addGlobalScalarTyCon tycon
+  = do { traceVt "addGlobalScalarTyCon" (ppr tycon)
+       ; updGEnv $ \env -> 
+           env{global_scalar_tycons = addOneToNameSet (global_scalar_tycons env) (tyConName tycon)}
+       }

compiler/vectorise/Vectorise/Monad/Global.hs

@@ -12,7 +12,7 @@ module Vectorise.Monad.Global (
   lookupVectDecl, noVectDecl, 
   
   -- * Scalars
-  globalScalarVars, isGlobalScalar, globalScalarTyCons,
+  globalScalarVars, isGlobalScalarVar, globalScalarTyCons,
   
   -- * TyCons
   lookupTyCon,
@@ -96,8 +96,8 @@ globalScalarVars = readGEnv global_scalar_vars
 
 -- |Check whether a given variable is in the set of global scalar variables.
 --
-isGlobalScalar :: Var -> VM Bool
-isGlobalScalar var = readGEnv $ \env -> var `elemVarSet` global_scalar_vars env
+isGlobalScalarVar :: Var -> VM Bool
+isGlobalScalarVar var = readGEnv $ \env -> var `elemVarSet` global_scalar_vars env
 
 -- |Get the set of global scalar type constructors including both those scalar type constructors
 -- declared in an imported module and those declared in the current module.

compiler/vectorise/Vectorise/Type/Env.hs

@@ -32,14 +32,18 @@ import Id
 import MkId
 import NameEnv
 import NameSet
+import OccName
 
 import Util
 import Outputable
 import FastString
 import MonadUtils
+
 import Control.Monad
+import Data.Maybe
 import Data.List
 
+
 -- Note [Pragmas to vectorise tycons]
 -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 --
@@ -60,7 +64,20 @@ import Data.List
 --     Type constructors declared with {-# VECTORISE SCALAR type T #-} are treated in this manner.
 --     (The vectoriser never treats a type constructor automatically in this manner.)
 --
--- (2) Data type constructor 'T' that together with its constructors 'Cn' may be used in vectorised
+-- (2) Data type constructor 'T' that may be used in vectorised code, where 'T' is represented by an
+--     explicitly given 'Tv', but the representation of 'T' is opaque in vectorised code.  
+--
+--     An example is the treatment of '[::]'.  '[::]'s can be used in vectorised code and is
+--     vectorised to 'PArray'.  However, the representation of '[::]' is not exposed in vectorised
+--     code.  Instead, computations involving the representation need to be confined to scalar code.
+--
+--     'PData' and 'PRepr' instances need to be explicitly supplied for 'T' (they are not generated
+--     by the vectoriser).
+--
+--     Type constructors declared with {-# VECTORISE SCALAR type T = T' #-} are treated in this 
+--     manner. (The vectoriser never treats a type constructor automatically in this manner.)
+--
+-- (3) Data type constructor 'T' that together with its constructors 'Cn' may be used in vectorised
 --     code, where 'T' and the 'Cn' are automatically vectorised in the same manner as data types
 --     declared in a vectorised module.  This includes the case where the vectoriser determines that
 --     the original representation of 'T' may be used in vectorised code (as it does not embed any
@@ -74,13 +91,13 @@ import Data.List
 --
 --     Type constructors declared with {-# VECTORISE type T #-} are treated in this manner.
 --
--- (3) Data type constructor 'T' that together with its constructors 'Cn' may be used in vectorised
+-- (4) Data type constructor 'T' that together with its constructors 'Cn' may be used in vectorised
 --     code, where 'T' is represented by an explicitly given 'Tv' whose constructors 'Cvn' represent
 --     the original constructors in vectorised code.  As a special case, we can have 'Tv = T'
 --
 --     An example is the treatment of 'Bool', which is represented by itself in vectorised code
 --     (as it cannot embed any parallel arrays).  However, we do not want any automatic generation
---     of class and family instances, which is why Case (2) does not apply.
+--     of class and family instances, which is why Case (3) does not apply.
 --
 --     'PData' and 'PRepr' instances need to be explicitly supplied for 'T' (they are not generated
 --     by the vectoriser).
@@ -139,35 +156,37 @@ vectTypeEnv tycons vectTypeDecls vectClassDecls
                                             allScalarTyConNames
 
        ; let   -- {-# VECTORISE SCALAR type T -#} (imported and local tycons)
-             localScalarTyCons      = [tycon | VectType True  tycon Nothing <- vectTypeDecls]
+             localAbstractTyCons    = [tycon | VectType True tycon Nothing <- vectTypeDecls]
 
                -- {-# VECTORISE type T -#} (ONLY the imported tycons)
              impVectTyCons          = (   [tycon | VectType False tycon Nothing <- vectTypeDecls]
                                        ++ [tycon | VectClass tycon              <- vectClassDecls])
                                       \\ tycons
 
-               -- {-# VECTORISE type T = ty -#} (imported and local tycons)
-             vectTyConsWithRHS      = [ (tycon, rhs) 
-                                      | VectType False tycon (Just rhs) <- vectTypeDecls]
+               -- {-# VECTORISE [SCALAR] type T = T' -#} (imported and local tycons)
+             vectTyConsWithRHS      = [ (tycon, rhs, isAbstract) 
+                                      | VectType isAbstract tycon (Just rhs) <- vectTypeDecls]
 
                -- filter VECTORISE SCALAR tycons and VECTORISE tycons with explicit rhses
              vectSpecialTyConNames  = mkNameSet . map tyConName $
-                                        localScalarTyCons ++ map fst vectTyConsWithRHS
-             notLocalScalarTyCon tc = not $ (tyConName tc) `elemNameSet` vectSpecialTyConNames
+                                        localAbstractTyCons ++ map fst3 vectTyConsWithRHS
+             notVectSpecialTyCon tc = not $ (tyConName tc) `elemNameSet` vectSpecialTyConNames
 
            -- Split the list of 'TyCons' into the ones (1) that we must vectorise and those (2)
            -- that we could, but don't need to vectorise.  Type constructors that are not data
            -- type constructors or use non-Haskell98 features are being dropped.  They may not
            -- appear in vectorised code.  (We also drop the local type constructors appearing in a
            -- VECTORISE SCALAR pragma or a VECTORISE pragma with an explicit right-hand side, as
-           -- these are being handled separately.)
+           -- these are being handled separately.  NB: Some type constructors may be marked SCALAR
+           -- /and/ have an explicit right-hand side.)
+           --
            -- Furthermore, 'drop_tcs' are those type constructors that we cannot vectorise.
-       ; let maybeVectoriseTyCons           = filter notLocalScalarTyCon tycons ++ impVectTyCons
+       ; let maybeVectoriseTyCons           = filter notVectSpecialTyCon tycons ++ impVectTyCons
              (conv_tcs, keep_tcs, drop_tcs) = classifyTyCons vectTyConFlavour maybeVectoriseTyCons
              
-       ; traceVt " VECT SCALAR    : " $ ppr localScalarTyCons
+       ; traceVt " VECT SCALAR    : " $ ppr localAbstractTyCons
        ; traceVt " VECT [class]   : " $ ppr impVectTyCons
-       ; traceVt " VECT with rhs  : " $ ppr (map fst vectTyConsWithRHS)
+       ; traceVt " VECT with rhs  : " $ ppr (map fst3 vectTyConsWithRHS)
        ; traceVt " -- after classification (local and VECT [class] tycons) --" empty
        ; traceVt " reuse          : " $ ppr keep_tcs
        ; traceVt " convert        : " $ ppr conv_tcs
@@ -180,24 +199,22 @@ vectTypeEnv tycons vectTypeDecls vectClassDecls
            emitVt "Warning: cannot vectorise these type constructors:" $ 
              pprQuotedList drop_tcs_nosyn $$ explanation
 
-       ; let defTyConDataCons origTyCon vectTyCon
-               = do { defTyCon origTyCon vectTyCon
-                    ; MASSERT(length (tyConDataCons origTyCon) == length (tyConDataCons vectTyCon))
-                    ; zipWithM_ defDataCon (tyConDataCons origTyCon) (tyConDataCons vectTyCon)
-                    }
-
-           -- For the type constructors that we don't need to vectorise, we use the original
-           -- representation in both unvectorised and vectorised code.
-       ; zipWithM_ defTyConDataCons keep_tcs keep_tcs
-
-           -- We do the same for type constructors declared VECTORISE SCALAR, while ignoring their
-           -- representation (data constructors) — see "Note [Pragmas to vectorise tycons]".
-       ; zipWithM_ defTyCon localScalarTyCons localScalarTyCons
-
-           -- For type constructors declared VECTORISE with an explicit vectorised type, we use the
-           -- explicitly given type in vectorised code and map data constructors one for one — see
-           -- "Note [Pragmas to vectorise tycons]".
-       ; mapM_ (uncurry defTyConDataCons) vectTyConsWithRHS
+       ; mapM_ addGlobalScalarTyCon keep_tcs
+
+       ; let mapping =      
+                    -- Type constructors that we don't need to vectorise, use the same
+                    -- representation in both unvectorised and vectorised code; they are not
+                    -- abstract.
+                  [(tycon, tycon, False