Move vectorisation of (->) & [::] into the library

- (->), [::], & PArray are now vectorised via pragmas (and related clean up)
- Repeatedly vectorising a variable or type constructor now raises an error

6 files changed, 45 insertions, 46 deletions

diff --git a/compiler/vectorise/Vectorise/Builtins.hs b/compiler/vectorise/Vectorise/Builtins.hs
index 8465c203b0..d194135951 100644
--- a/compiler/vectorise/Vectorise/Builtins.hs
+++ b/compiler/vectorise/Vectorise/Builtins.hs
@@ -8,7 +8,6 @@ module Vectorise.Builtins (
   Builtins(..),
   
   -- * Wrapped selectors
-  parray_PrimTyCon,
   selTy, selsTy,
   selReplicate,
   selTags,
@@ -26,7 +25,7 @@ module Vectorise.Builtins (
   closureCtrFun,
 
   -- * Initialisation
-  initBuiltins, initBuiltinVars, initBuiltinTyCons
+  initBuiltins, initBuiltinVars,
 ) where
 
 import Vectorise.Builtins.Base
diff --git a/compiler/vectorise/Vectorise/Builtins/Base.hs b/compiler/vectorise/Vectorise/Builtins/Base.hs
index 586c950f62..90afedfb87 100644
--- a/compiler/vectorise/Vectorise/Builtins/Base.hs
+++ b/compiler/vectorise/Vectorise/Builtins/Base.hs
@@ -13,7 +13,6 @@ module Vectorise.Builtins.Base (
   Builtins(..),
   
   -- * Projections
-  parray_PrimTyCon,
   selTy, selsTy,
   selReplicate,
   selTags,
@@ -71,9 +70,7 @@ aLL_DPH_PRIM_TYCONS = map tyConName [intPrimTyCon, {- floatPrimTyCon, -} doubleP
 --
 data Builtins 
         = Builtins 
-        { parrayTyCon          :: TyCon                     -- ^ PArray
-        , parray_PrimTyCons    :: NameEnv TyCon             -- ^ PArray_Int# etc.
-        , pdataTyCon           :: TyCon                     -- ^ PData
+        { pdataTyCon           :: TyCon                     -- ^ PData
         , pdatasTyCon          :: TyCon                     -- ^ PDatas
         , prClass              :: Class                     -- ^ PR
         , prTyCon              :: TyCon                     -- ^ PR
@@ -119,9 +116,6 @@ data Builtins
 -- We use these wrappers instead of indexing the `Builtin` structure directly
 -- because they give nicer panic messages if the indexed thing cannot be found.
 
-parray_PrimTyCon :: TyCon -> Builtins -> TyCon
-parray_PrimTyCon tc bi = lookupEnvBuiltin "parray_PrimTyCon" (parray_PrimTyCons bi) (tyConName tc)
-
 selTy :: Int -> Builtins -> Type
 selTy           = indexBuiltin "selTy" selTys
 
diff --git a/compiler/vectorise/Vectorise/Builtins/Initialise.hs b/compiler/vectorise/Vectorise/Builtins/Initialise.hs
index e2fddefacd..1ef8183869 100644
--- a/compiler/vectorise/Vectorise/Builtins/Initialise.hs
+++ b/compiler/vectorise/Vectorise/Builtins/Initialise.hs
@@ -2,7 +2,7 @@
 
 module Vectorise.Builtins.Initialise (
   -- * Initialisation
-  initBuiltins, initBuiltinVars, initBuiltinTyCons
+  initBuiltins, initBuiltinVars
 ) where
 
 import Vectorise.Builtins.Base
@@ -30,12 +30,7 @@ import Data.Array
 --
 initBuiltins :: DsM Builtins
 initBuiltins
- = do {   -- 'PArray': desugared array type
-      ; parrayTyCon <- externalTyCon (fsLit "PArray")
-      ; parray_tcs  <- mapM externalTyCon (suffixed "PArray" aLL_DPH_PRIM_TYCONS)
-      ; let parray_PrimTyCons = mkNameEnv (zip aLL_DPH_PRIM_TYCONS parray_tcs)
-
-          -- 'PData': type family mapping array element types to array representation types
+ = do {   -- 'PData': type family mapping array element types to array representation types
           -- Not all backends use `PDatas`.
       ; pdataTyCon  <- externalTyCon (fsLit "PData")
       ; pdatasTyCon <- externalTyCon (fsLit "PDatas")
@@ -80,7 +75,8 @@ initBuiltins
       ; scalar_map       <- externalVar (fsLit "scalar_map")
       ; scalar_zip2      <- externalVar (fsLit "scalar_zipWith")
       ; scalar_zips      <- mapM externalVar (numbered "scalar_zipWith" 3 mAX_DPH_SCALAR_ARGS)
-      ; let scalarZips   = listArray (1, mAX_DPH_SCALAR_ARGS) (scalar_map : scalar_zip2 : scalar_zips)
+      ; let scalarZips   = listArray (1, mAX_DPH_SCALAR_ARGS) 
+                                     (scalar_map : scalar_zip2 : scalar_zips)
 
           -- Types and functions for generic type representations
       ; voidTyCon        <- externalTyCon (fsLit "Void")
@@ -119,9 +115,7 @@ initBuiltins
       ; liftingContext  <- liftM (\u -> mkSysLocal (fsLit "lc") u intPrimTy) newUnique
 
       ; return $ Builtins 
-               { parrayTyCon          = parrayTyCon
-               , parray_PrimTyCons    = parray_PrimTyCons
-               , pdataTyCon           = pdataTyCon
+               { pdataTyCon           = pdataTyCon
                , pdatasTyCon          = pdatasTyCon
                , preprTyCon           = preprTyCon
                , prClass              = prClass
@@ -196,20 +190,6 @@ initBuiltinVars (Builtins { })
       where
         mk_tup n name = (tupleCon BoxedTuple n, name)
 
--- |Get a list of names to `TyCon`s in the mock prelude.
---
-initBuiltinTyCons :: Builtins -> DsM [(Name, TyCon)]
--- FIXME: * must be replaced by VECTORISE pragmas!!!
---        * then we can remove 'parrayTyCon' from the Builtins as well
-initBuiltinTyCons bi
-  = do
-      return $ (tyConName funTyCon, closureTyCon bi)
-             : (parrTyConName,      parrayTyCon bi)
-
-             -- FIXME: temporary
-             : (tyConName $ parrayTyCon bi, parrayTyCon bi)
-             : []
-
 
 -- Auxilliary look up functions -----------------------------------------------
 
diff --git a/compiler/vectorise/Vectorise/Env.hs b/compiler/vectorise/Vectorise/Env.hs
index ffaf388b31..166262f744 100644
--- a/compiler/vectorise/Vectorise/Env.hs
+++ b/compiler/vectorise/Vectorise/Env.hs
@@ -10,7 +10,6 @@ module Vectorise.Env (
   initGlobalEnv,
   extendImportedVarsEnv,
   extendFamEnv,
-  extendTyConsEnv,
   setPAFunsEnv,
   setPRFunsEnv,
   modVectInfo
@@ -182,12 +181,6 @@ extendFamEnv new genv
   = genv { global_fam_inst_env = (g_fam_inst, extendFamInstEnvList l_fam_inst new) }
   where (g_fam_inst, l_fam_inst) = global_fam_inst_env genv
 
--- |Extend the list of type constructors in an environment.
---
-extendTyConsEnv :: [(Name, TyCon)] -> GlobalEnv -> GlobalEnv
-extendTyConsEnv ps genv
-  = genv { global_tycons = extendNameEnvList (global_tycons genv) ps }
-
 -- |Set the list of PA functions in an environment.
 --
 setPAFunsEnv :: [(Name, Var)] -> GlobalEnv -> GlobalEnv
diff --git a/compiler/vectorise/Vectorise/Monad.hs b/compiler/vectorise/Vectorise/Monad.hs
index 0706e25f4f..a6bf6d973f 100644
--- a/compiler/vectorise/Vectorise/Monad.hs
+++ b/compiler/vectorise/Vectorise/Monad.hs
@@ -80,7 +80,6 @@ initV hsc_env guts info thing_inside
       = do {   -- set up tables of builtin entities
            ; builtins        <- initBuiltins
            ; builtin_vars    <- initBuiltinVars builtins
-           ; builtin_tycons  <- initBuiltinTyCons builtins
 
                -- set up class and type family envrionments
            ; eps <- liftIO $ hscEPS hsc_env
@@ -91,7 +90,6 @@ initV hsc_env guts info thing_inside
 
                -- construct the initial global environment
            ; let genv = extendImportedVarsEnv builtin_vars
-                        . extendTyConsEnv     builtin_tycons
                         . setPAFunsEnv        builtin_pas
                         . setPRFunsEnv        builtin_prs
                         $ initGlobalEnv info (mg_vect_decls guts) instEnvs famInstEnvs
diff --git a/compiler/vectorise/Vectorise/Monad/Global.hs b/compiler/vectorise/Vectorise/Monad/Global.hs
index f393f01e92..bb8cc1affa 100644
--- a/compiler/vectorise/Vectorise/Monad/Global.hs
+++ b/compiler/vectorise/Vectorise/Monad/Global.hs
@@ -39,8 +39,11 @@ import TyCon
 import DataCon
 import NameEnv
 import NameSet
+import Name
 import VarEnv
 import VarSet
+import Var as Var
+import FastString
 import Outputable
 
 
@@ -70,8 +73,22 @@ defGlobalVar :: Var -> Var -> VM ()
 defGlobalVar v v'
   = do { traceVt "add global var mapping:" (ppr v <+> text "-->" <+> ppr v') 
 
-       ; updGEnv $ \env -> env { global_vars = extendVarEnv (global_vars env) v v' }
+           -- check for duplicate vectorisation
+       ; currentDef <- readGEnv $ \env -> lookupVarEnv (global_vars env) v
+       ; case currentDef of
+           Just old_v' -> cantVectorise "Variable is already vectorised:" $
+                            ppr v <+> moduleOf v old_v'
+           Nothing     -> return ()
+
+       ; updGEnv  $ \env -> env { global_vars = extendVarEnv (global_vars env) v v' }
        }
+  where
+    moduleOf var var' | var == var'
+                      = ptext (sLit "vectorises to itself")
+                      | Just mod <- nameModule_maybe (Var.varName var') 
+                      = ptext (sLit "in module") <+> ppr mod
+                      | otherwise
+                      = ptext (sLit "in the current module")
 
 
 -- Vectorisation declarations -------------------------------------------------
@@ -120,8 +137,26 @@ lookupTyCon tc
 -- |Add a mapping between plain and vectorised `TyCon`s to the global environment.
 --
 defTyCon :: TyCon -> TyCon -> VM ()
-defTyCon tc tc' = updGEnv $ \env ->
-  env { global_tycons = extendNameEnv (global_tycons env) (tyConName tc) tc' }
+defTyCon tc tc'
+  = do { traceVt "add global tycon mapping:" (ppr tc <+> text "-->" <+> ppr tc') 
+
+           -- check for duplicate vectorisation
+       ; currentDef <- readGEnv $ \env -> lookupNameEnv (global_tycons env) (tyConName tc)
+       ; case currentDef of
+           Just old_tc' -> cantVectorise "Type constructor or class is already vectorised:" $
+                            ppr tc <+> moduleOf tc old_tc'
+           Nothing     -> return ()
+
+       ; updGEnv $ \env -> 
+           env { global_tycons = extendNameEnv (global_tycons env) (tyConName tc) tc' }
+       }
+  where
+    moduleOf tc tc' | tc == tc'
+                    = ptext (sLit "vectorises to itself")
+                    | Just mod <- nameModule_maybe (tyConName tc') 
+                    = ptext (sLit "in module") <+> ppr mod
+                    | otherwise
+                    = ptext (sLit "in the current module")
 
 -- |Get the set of all vectorised type constructors.
 --