Added a VECTORISE pragma

- Added a pragma {-# VECTORISE var = exp #-} that prevents
  the vectoriser from vectorising the definition of 'var'.
  Instead it uses the binding '$v_var = exp' to vectorise
  'var'.  The vectoriser checks that the Core type of 'exp'
  matches the vectorised Core type of 'var'.  (It would be
  quite complicated to perform that check in the type checker
  as the vectorisation of a type needs the state of the VM
  monad.)
- Added parts of a related VECTORISE SCALAR pragma
- Documented -ddump-vect
- Added -ddump-vt-trace
- Some clean up

11 files changed, 367 insertions, 245 deletions

diff --git a/compiler/vectorise/Vectorise.hs b/compiler/vectorise/Vectorise.hs
index e3e9646a19..72cca6e1c6 100644
--- a/compiler/vectorise/Vectorise.hs
+++ b/compiler/vectorise/Vectorise.hs
@@ -1,6 +1,6 @@
 {-# OPTIONS -fno-warn-missing-signatures #-}
 
-module Vectorise( vectorise )
+module Vectorise ( vectorise )
 where
 
 import Vectorise.Type.Env
@@ -13,14 +13,16 @@ import Vectorise.Env
 import Vectorise.Monad
 
 import HscTypes hiding      ( MonadThings(..) )
-import Module               ( PackageId )
-import CoreSyn
 import CoreUnfold           ( mkInlineUnfolding )
 import CoreFVs
+import PprCore
+import CoreSyn
 import CoreMonad            ( CoreM, getHscEnv )
+import Type
 import Var
 import Id
 import OccName
+import DynFlags
 import BasicTypes           ( isLoopBreaker )
 import Outputable
 import Util                 ( zipLazy )
@@ -28,53 +30,58 @@ import MonadUtils
 
 import Control.Monad
 
-debug		= False
-dtrace s x	= if debug then pprTrace "Vectorise" s x else x
 
 -- | Vectorise a single module.
---   Takes the package containing the DPH backend we're using. Eg either dph-par or dph-seq.
-vectorise :: PackageId -> ModGuts -> CoreM ModGuts
-vectorise backend guts 
- = do hsc_env <- getHscEnv
-      liftIO $ vectoriseIO backend hsc_env guts
-
-
--- | Vectorise a single monad, given its HscEnv (code gen environment).
-vectoriseIO :: PackageId -> HscEnv -> ModGuts -> IO ModGuts
-vectoriseIO backend hsc_env guts
- = do -- Get information about currently loaded external packages.
-      eps <- hscEPS hsc_env
+--
+vectorise :: ModGuts -> CoreM ModGuts
+vectorise guts
+ = do { hsc_env <- getHscEnv
+      ; liftIO $ vectoriseIO hsc_env guts
+      }
 
-      -- Combine vectorisation info from the current module, and external ones.
-      let info = hptVectInfo hsc_env `plusVectInfo` eps_vect_info eps
+-- | Vectorise a single monad, given the dynamic compiler flags and HscEnv.
+--
+vectoriseIO :: HscEnv -> ModGuts -> IO ModGuts
+vectoriseIO hsc_env guts
+ = do {   -- Get information about currently loaded external packages.
+      ; eps <- hscEPS hsc_env
 
-      -- Run the main VM computation.
-      Just (info', guts') <- initV backend hsc_env guts info (vectModule guts)
-      return (guts' { mg_vect_info = info' })
+          -- Combine vectorisation info from the current module, and external ones.
+      ; let info = hptVectInfo hsc_env `plusVectInfo` eps_vect_info eps
 
+          -- Run the main VM computation.
+      ; Just (info', guts') <- initV hsc_env guts info (vectModule guts)
+      ; return (guts' { mg_vect_info = info' })
+      }
 
 -- | Vectorise a single module, in the VM monad.
+--
 vectModule :: ModGuts -> VM ModGuts
-vectModule guts
- = do -- Vectorise the type environment.
-      -- This may add new TyCons and DataCons.
-      -- TODO: What new binds do we get back here?
-      (types', fam_insts, tc_binds) <- vectTypeEnv (mg_types guts)
-
-      (_, fam_inst_env) <- readGEnv global_fam_inst_env
+vectModule guts@(ModGuts { mg_types     = types
+                         , mg_binds     = binds
+                         , mg_fam_insts = fam_insts
+                         })
+ = do { dumpOptVt Opt_D_dump_vt_trace "Before vectorisation" $ 
+          pprCoreBindings binds
+ 
+          -- Vectorise the type environment.
+          -- This may add new TyCons and DataCons.
+      ; (types', new_fam_insts, tc_binds) <- vectTypeEnv types
+
+      ; (_, fam_inst_env) <- readGEnv global_fam_inst_env
 
       -- dicts   <- mapM buildPADict pa_insts
       -- workers <- mapM vectDataConWorkers pa_insts
 
-      -- Vectorise all the top level bindings.
-      binds'  <- mapM vectTopBind (mg_binds guts)
-
-      return $ guts { mg_types        = types'
-                    , mg_binds        = Rec tc_binds : binds'
-                    , mg_fam_inst_env = fam_inst_env
-                    , mg_fam_insts    = mg_fam_insts guts ++ fam_insts
-                    }
+          -- Vectorise all the top level bindings.
+      ; binds'  <- mapM vectTopBind binds
 
+      ; return $ guts { mg_types        = types'
+                      , mg_binds        = Rec tc_binds : binds'
+                      , mg_fam_inst_env = fam_inst_env
+                      , mg_fam_insts    = fam_insts ++ new_fam_insts
+                      }
+      }
 
 -- | Try to vectorise a top-level binding.
 --   If it doesn't vectorise then return it unharmed.
@@ -116,14 +123,14 @@ vectTopBind :: CoreBind -> VM CoreBind
 vectTopBind b@(NonRec var expr)
  = do
       (inline, _, expr') 	<- vectTopRhs [] var expr
-      var' 		<- vectTopBinder var inline expr'
+      var' <- vectTopBinder var inline expr'
 
       -- Vectorising the body may create other top-level bindings.
-      hs	<- takeHoisted
+      hs <- takeHoisted
 
       -- To get the same functionality as the original body we project
       -- out its vectorised version from the closure.
-      cexpr	<- tryConvert var var' expr
+      cexpr <- tryConvert var var' expr
 
       return . Rec $ (var, cexpr) : (var', expr') : hs
   `orElseV`
@@ -132,7 +139,7 @@ vectTopBind b@(NonRec var expr)
 vectTopBind b@(Rec bs)
  = do
       (vars', _, exprs') 
-	<- fixV $ \ ~(_, inlines, rhss) ->
+        <- fixV $ \ ~(_, inlines, rhss) ->
             do vars' <- sequence [vectTopBinder var inline rhs
                                       | (var, ~(inline, rhs)) <- zipLazy vars (zip inlines rhss)]
                (inlines', areScalars', exprs') 
@@ -152,67 +159,109 @@ vectTopBind b@(Rec bs)
     return b
   where
     (vars, exprs) = unzip bs
-    mapAndUnzip3M f xs = do
-       ys <- mapM f xs
-       return $ unzip3 ys
-
+    
 -- | Make the vectorised version of this top level binder, and add the mapping
 --   between it and the original to the state. For some binder @foo@ the vectorised
 --   version is @$v_foo@
 --
 --   NOTE: vectTopBinder *MUST* be lazy in inline and expr because of how it is
 --   used inside of fixV in vectTopBind
-vectTopBinder 
-	:: Var 		-- ^ Name of the binding.
-	-> Inline 	-- ^ Whether it should be inlined, used to annotate it.
-	-> CoreExpr 	-- ^ RHS of the binding, used to set the `Unfolding` of the returned `Var`.
-	-> VM Var	-- ^ Name of the vectorised binding.
-
+--
+vectTopBinder :: Var      -- ^ Name of the binding.
+              -> Inline   -- ^ Whether it should be inlined, used to annotate it.
+              -> CoreExpr -- ^ RHS of binding, used to set the 'Unfolding' of the returned 'Var'.
+              -> VM Var   -- ^ Name of the vectorised binding.
 vectTopBinder var inline expr
- = do
-      -- Vectorise the type attached to the var.
-      vty  <- vectType (idType var)
-
-      -- Make the vectorised version of binding's name, and set the unfolding used for inlining.
-      var' <- liftM (`setIdUnfoldingLazily` unfolding) 
-           $  cloneId mkVectOcc var vty
-
-      -- Add the mapping between the plain and vectorised name to the state.
-      defGlobalVar var var'
-
-      return var'
+ = do {   -- Vectorise the type attached to the var.
+      ; vty  <- vectType (idType var)
+      
+          -- If there is a vectorisation declartion for this binding, make sure that its type
+          --  matches
+      ; vectDecl <- lookupVectDecl var
+      ; case vectDecl of
+          Nothing                 -> return ()
+          Just (vdty, _) 
+            | coreEqType vty vdty -> return ()
+            | otherwise           -> 
+              cantVectorise ("Type mismatch in vectorisation pragma for " ++ show var) $
+                (text "Expected type" <+> ppr vty)
+                $$
+                (text "Inferred type" <+> ppr vdty)
+
+          -- Make the vectorised version of binding's name, and set the unfolding used for inlining
+      ; var' <- liftM (`setIdUnfoldingLazily` unfolding) 
+                $  cloneId mkVectOcc var vty
+
+          -- Add the mapping between the plain and vectorised name to the state.
+      ; defGlobalVar var var'
+
+      ; return var'
+    }
   where
     unfolding = case inline of
                   Inline arity -> mkInlineUnfolding (Just arity) expr
                   DontInline   -> noUnfolding
 
-
 -- | Vectorise the RHS of a top-level binding, in an empty local environment.
-vectTopRhs 
-	:: [Var]    -- ^ Names of all functions in the rec block
-	-> Var 		-- ^ Name of the binding.
-	-> CoreExpr	-- ^ Body of the binding.
-	-> VM (Inline, Bool, CoreExpr)
-
+--
+-- We need to distinguish three cases:
+--
+-- (1) We have a (non-scalar) vectorisation declaration for the variable (which explicitly provides
+--     vectorised code implemented by the user)
+--     => no automatic vectorisation & instead use the user-supplied code
+-- 
+-- (2) We have a scalar vectorisation declaration for the variable
+--     => generate vectorised code that uses a scalar 'map'/'zipWith' to lift the computation
+-- 
+-- (3) There is no vectorisation declaration for the variable
+--     => perform automatic vectorisation of the RHS
+--
+vectTopRhs :: [Var]           -- ^ Names of all functions in the rec block
+           -> Var             -- ^ Name of the binding.
+           -> CoreExpr        -- ^ Body of the binding.
+           -> VM ( Inline     -- (1) inline specification for the binding
+                 , Bool       -- (2) whether the right-hand side is a scalar computation
+                 , CoreExpr)  -- (3) the vectorised right-hand side
 vectTopRhs recFs var expr
- = dtrace (vcat [text "vectTopRhs", ppr expr])
- $ closedV
- $ do (inline, isScalar, vexpr) <- 
-           inBind var $ vectPolyExpr  (isLoopBreaker $ idOccInfo var) recFs (freeVars expr)
-      if isScalar 
-         then addGlobalScalar var
-         else deleteGlobalScalar var
-      return (inline, isScalar, vectorised vexpr)
-
+  = closedV
+  $ do { traceVt ("vectTopRhs of " ++ show var) $ ppr expr
+  
+       ; globalScalar <- isGlobalScalar var
+       ; vectDecl     <- lookupVectDecl var
+       ; rhs globalScalar vectDecl
+       }
+  where
+    rhs _globalScalar (Just (_, expr'))               -- Case (1)
+      = return (inlineMe, False, expr')
+    rhs True          _vectDecl                       -- Case (2)
+      = return (inlineMe, True, scalarRHS)
+                          -- FIXME: that True is not enough to register scalarness
+    rhs False         _vectDecl                       -- Case (3)
+      = do { let fvs = freeVars expr
+           ; (inline, isScalar, vexpr) <- inBind var $
+                                            vectPolyExpr (isLoopBreaker $ idOccInfo var) recFs fvs
+           ; if isScalar 
+             then addGlobalScalar var
+             else deleteGlobalScalar var
+           ; return (inline, isScalar, vectorised vexpr)
+           }
+      
+    -- For scalar right-hand sides, we know that the original binding will remain unaltered
+    -- (hence, we can refer to it without risk of cycles) - cf, 'tryConvert'.
+    scalarRHS = panic "Vectorise.scalarRHS: not implemented yet"
 
 -- | Project out the vectorised version of a binding from some closure,
---	or return the original body if that doesn't work.	
-tryConvert 
-	:: Var	 	-- ^ Name of the original binding (eg @foo@)
-	-> Var 		-- ^ Name of vectorised version of binding (eg @$vfoo@)
-	-> CoreExpr	-- ^ The original body of the binding.
-	-> VM CoreExpr
-
+--   or return the original body if that doesn't work or the binding is scalar. 
+--
+tryConvert :: Var       -- ^ Name of the original binding (eg @foo@)
+           -> Var       -- ^ Name of vectorised version of binding (eg @$vfoo@)
+           -> CoreExpr  -- ^ The original body of the binding.
+           -> VM CoreExpr
 tryConvert var vect_var rhs
-  = fromVect (idType var) (Var vect_var) `orElseV` return rhs
-
+  = do { globalScalar <- isGlobalScalar var
+       ; if globalScalar
+         then
+           return rhs
+         else
+           fromVect (idType var) (Var vect_var) `orElseV` return rhs
+       }
diff --git a/compiler/vectorise/Vectorise/Builtins.hs b/compiler/vectorise/Vectorise/Builtins.hs
index 04e768b075..3647a7f875 100644
--- a/compiler/vectorise/Vectorise/Builtins.hs
+++ b/compiler/vectorise/Vectorise/Builtins.hs
@@ -1,6 +1,6 @@
 
 -- | Builtin types and functions used by the vectoriser.
---   The source program uses functions from GHC.PArr, which the vectoriser rewrites
+--   The source program uses functions from Data.Array.Parallel, which the vectoriser rewrites
 --   to use equivalent vectorised versions in the DPH backend packages.
 --
 --   The `Builtins` structure holds the name of all the things in the DPH packages
diff --git a/compiler/vectorise/Vectorise/Builtins/Initialise.hs b/compiler/vectorise/Vectorise/Builtins/Initialise.hs
index 9e78f112f9..94de62aa72 100644
--- a/compiler/vectorise/Vectorise/Builtins/Initialise.hs
+++ b/compiler/vectorise/Vectorise/Builtins/Initialise.hs
@@ -191,10 +191,11 @@ initBuiltins pkg
              $ mkFastString ("elementsSel" ++ show i ++ "_" ++ show j ++ "#")
           return ((i,j), Var v)
 
-
 -- | Get the mapping of names in the Prelude to names in the DPH library.
-initBuiltinVars :: Builtins -> DsM [(Var, Var)]
-initBuiltinVars (Builtins { dphModules = mods })
+--
+initBuiltinVars :: Bool   -- FIXME
+                -> Builtins -> DsM [(Var, Var)]
+initBuiltinVars compilingDPH (Builtins { dphModules = mods })
   = do
       uvars <- zipWithM externalVar umods ufs
       vvars <- zipWithM externalVar vmods vfs
@@ -203,7 +204,7 @@ initBuiltinVars (Builtins { dphModules = mods })
                ++ zip (map dataConWorkId cons) cvars
                ++ zip uvars vvars
   where
-    (umods, ufs, vmods, vfs) = unzip4 (preludeVars mods)
+    (umods, ufs, vmods, vfs) = if compilingDPH then ([], [], [], []) else unzip4 (preludeVars mods)
     (cons, cmods, cfs)       = unzip3 (preludeDataCons mods)
 
     defaultDataConWorkers :: [DataCon]
@@ -273,12 +274,12 @@ initBuiltinBoxedTyCons
 	builtinBoxedTyCons _ 
   		= [(tyConName intPrimTyCon, intTyCon)]
 
-
 -- | Get a list of all scalar functions in the mock prelude.
-initBuiltinScalars :: Builtins -> DsM [Var]
-initBuiltinScalars bi
-  = mapM (uncurry externalVar) (preludeScalars $ dphModules bi)
-
+--
+initBuiltinScalars :: Bool 
+                   -> Builtins -> DsM [Var]
+initBuiltinScalars True  _bi = return []
+initBuiltinScalars False bi  = mapM (uncurry externalVar) (preludeScalars $ dphModules bi)
 
 -- | Lookup some variable given its name and the module that contains it.
 externalVar :: Module -> FastString -> DsM Var
diff --git a/compiler/vectorise/Vectorise/Builtins/Prelude.hs b/compiler/vectorise/Vectorise/Builtins/Prelude.hs
index b578f3087c..b0f305da73 100644
--- a/compiler/vectorise/Vectorise/Builtins/Prelude.hs
+++ b/compiler/vectorise/Vectorise/Builtins/Prelude.hs
@@ -1,4 +1,7 @@
 
+-- WARNING: This module is a temporary kludge.  It will soon go away entirely (once 
+--   VECTORISE SCALAR pragmas are fully implemented.)
+
 -- | Mapping of prelude functions to vectorised versions.
 --     Functions like filterP currently have a working but naive version in GHC.PArr
 --     During vectorisation we replace these by calls to filterPA, which are
@@ -18,38 +21,36 @@ import Module
 import FastString
 
 
-preludeVars
-	:: Modules			-- ^ Modules containing the DPH backens
+preludeVars :: Modules
 	-> [( Module, FastString	--   Maps the original variable to the one in the DPH 
 	    , Module, FastString)]      --   packages that it should be rewritten to.
-
-preludeVars (Modules { dph_Combinators    = dph_Combinators
-                     , dph_PArray         = dph_PArray
+preludeVars (Modules { dph_Combinators    = _dph_Combinators
+                     , dph_PArray         = _dph_PArray
                      , dph_Prelude_Int    = dph_Prelude_Int
                      , dph_Prelude_Word8  = dph_Prelude_Word8
                      , dph_Prelude_Double = dph_Prelude_Double
                      , dph_Prelude_Bool   = dph_Prelude_Bool 
-                     , dph_Prelude_PArr   = dph_Prelude_PArr
+                     , dph_Prelude_PArr   = _dph_Prelude_PArr
                      })
 
     -- Functions that work on whole PArrays, defined in GHC.PArr
-  = [ mk gHC_PARR (fsLit "mapP")       dph_Combinators (fsLit "mapPA")
-    , mk gHC_PARR (fsLit "zipWithP")   dph_Combinators (fsLit "zipWithPA")
-    , mk gHC_PARR (fsLit "zipP")       dph_Combinators (fsLit "zipPA")
-    , mk gHC_PARR (fsLit "unzipP")     dph_Combinators (fsLit "unzipPA")
-    , mk gHC_PARR (fsLit "filterP")    dph_Combinators (fsLit "filterPA")
-    , mk gHC_PARR (fsLit "lengthP")    dph_Combinators (fsLit "lengthPA")
-    , mk gHC_PARR (fsLit "replicateP") dph_Combinators (fsLit "replicatePA")
-    , mk gHC_PARR (fsLit "!:")         dph_Combinators (fsLit "indexPA")
-    , mk gHC_PARR (fsLit "sliceP")     dph_Combinators (fsLit "slicePA")
-    , mk gHC_PARR (fsLit "crossMapP")  dph_Combinators (fsLit "crossMapPA")
-    , mk gHC_PARR (fsLit "singletonP") dph_Combinators (fsLit "singletonPA")
-    , mk gHC_PARR (fsLit "concatP")    dph_Combinators (fsLit "concatPA")
-    , mk gHC_PARR (fsLit "+:+")        dph_Combinators (fsLit "appPA")
-    , mk gHC_PARR (fsLit "emptyP")     dph_PArray      (fsLit "emptyPA")
+  = [ {- mk gHC_PARR' (fsLit "mapP")       dph_Combinators (fsLit "mapPA")
+    , mk gHC_PARR' (fsLit "zipWithP")   dph_Combinators (fsLit "zipWithPA")
+    , mk gHC_PARR' (fsLit "zipP")       dph_Combinators (fsLit "zipPA")
+    , mk gHC_PARR' (fsLit "unzipP")     dph_Combinators (fsLit "unzipPA")
+    , mk gHC_PARR' (fsLit "filterP")    dph_Combinators (fsLit "filterPA")
+    , mk gHC_PARR' (fsLit "lengthP")    dph_Combinators (fsLit "lengthPA")
+    , mk gHC_PARR' (fsLit "replicateP") dph_Combinators (fsLit "replicatePA")
+    , mk gHC_PARR' (fsLit "!:")         dph_Combinators (fsLit "indexPA")
+    , mk gHC_PARR' (fsLit "sliceP")     dph_Combinators (fsLit "slicePA")
+    , mk gHC_PARR' (fsLit "crossMapP")  dph_Combinators (fsLit "crossMapPA")
+    , mk gHC_PARR' (fsLit "singletonP") dph_Combinators (fsLit "singletonPA")
+    , mk gHC_PARR' (fsLit "concatP")    dph_Combinators (fsLit "concatPA")
+    , mk gHC_PARR' (fsLit "+:+")        dph_Combinators (fsLit "appPA")
+    , mk gHC_PARR' (fsLit "emptyP")     dph_PArray      (fsLit "emptyPA")
 
     -- Map scalar functions to versions using closures. 
-    , mk' dph_Prelude_Int "div"         "divV"
+    , -} mk' dph_Prelude_Int "div"         "divV"
     , mk' dph_Prelude_Int "mod"         "modV"
     , mk' dph_Prelude_Int "sqrt"        "sqrtV"
     , mk' dph_Prelude_Int "enumFromToP" "enumFromToPA"
@@ -80,6 +81,7 @@ preludeVars (Modules { dph_Combinators    = dph_Combinators
     , mk gHC_CLASSES (fsLit "&&")          dph_Prelude_Bool (fsLit "andV")
     , mk gHC_CLASSES (fsLit "||")          dph_Prelude_Bool (fsLit "orV")
 
+{-
     -- FIXME: temporary
     , mk dph_Prelude_PArr (fsLit "fromPArrayP")       dph_Prelude_PArr (fsLit "fromPArrayPA")
     , mk dph_Prelude_PArr (fsLit "toPArrayP")         dph_Prelude_PArr (fsLit "toPArrayPA")
@@ -88,7 +90,7 @@ preludeVars (Modules { dph_Combinators    = dph_Combinators
     , mk dph_Prelude_PArr (fsLit "updateP")           dph_Combinators  (fsLit "updatePA")
     , mk dph_Prelude_PArr (fsLit "bpermuteP")         dph_Combinators  (fsLit "bpermutePA")
     , mk dph_Prelude_PArr (fsLit "indexedP")          dph_Combinators  (fsLit "indexedPA")
-    ]
+-}    ]
   where
     mk  = (,,,)
     mk' mod v v' = mk mod (fsLit v) mod (fsLit v')
@@ -152,7 +154,6 @@ preludeVars (Modules { dph_Combinators    = dph_Combinators
        , mk' mod "floor"    "floorV"
        ]
 
-
 preludeScalars :: Modules -> [(Module, FastString)]
 preludeScalars (Modules { dph_Prelude_Int    = dph_Prelude_Int
                         , dph_Prelude_Word8  = dph_Prelude_Word8
diff --git a/compiler/vectorise/Vectorise/Env.hs b/compiler/vectorise/Vectorise/Env.hs
index 70ed8c4555..9a1fd4431a 100644
--- a/compiler/vectorise/Vectorise/Env.hs
+++ b/compiler/vectorise/Vectorise/Env.hs
@@ -20,10 +20,12 @@ module Vectorise.Env (
 	setBoxedTyConsEnv,
 	updVectInfo
 ) where
+
 import HscTypes
 import InstEnv
 import FamInstEnv
 import CoreSyn
+import Type
 import TyCon
 import DataCon
 import VarEnv
@@ -70,15 +72,22 @@ emptyLocalEnv = LocalEnv {
 
 -- GlobalEnv ------------------------------------------------------------------
 -- | The global environment.
---	These are things the exist at top-level.
+--      These are things the exist at top-level.
 data GlobalEnv 
-	= GlobalEnv {
+        = GlobalEnv {
         -- | Mapping from global variables to their vectorised versions.
-          global_vars		:: VarEnv Var
+          global_vars           :: VarEnv Var
+
+        -- | Mapping from global variables that have a vectorisation declaration to the right-hand
+        --   side of that declaration and its type.  This mapping only applies to non-scalar
+        --   vectorisation declarations.  All variables with a scalar vectorisation declaration are
+        --   mentioned in 'global_scalars'.
+        , global_vect_decls     :: VarEnv (Type, CoreExpr)
 
-        -- | Purely scalar variables. Code which mentions only these
-        --   variables doesn't have to be lifted.
-        , global_scalars	:: VarSet
+        -- | Purely scalar variables. Code which mentions only these variables doesn't have to be
+        --   lifted.  This includes variables from the current module that have a scalar
+        --   vectorisation declaration and those that the vectoriser determines to be scalar.
+        , global_scalars        :: VarSet
 
         -- | Exported variables which have a vectorised version.
         , global_exported_vars	:: VarEnv (Var, Var)
@@ -88,10 +97,10 @@ data GlobalEnv
         , global_tycons		:: NameEnv TyCon
 
         -- | Mapping from DataCons to their vectorised versions.
-        , global_datacons	:: NameEnv DataCon
+        , global_datacons       :: NameEnv DataCon
 
         -- | Mapping from TyCons to their PA dfuns.
-	, global_pa_funs	:: NameEnv Var
+        , global_pa_funs        :: NameEnv Var
 
         -- | Mapping from TyCons to their PR dfuns.
         , global_pr_funs	:: NameEnv Var
@@ -109,24 +118,26 @@ data GlobalEnv
         , global_bindings	:: [(Var, CoreExpr)]
         }
 
-
 -- | Create an initial global environment
-initGlobalEnv :: VectInfo -> (InstEnv, InstEnv) -> FamInstEnvs -> GlobalEnv
-initGlobalEnv info instEnvs famInstEnvs
-	= GlobalEnv 
-	{ global_vars          = mapVarEnv snd $ vectInfoVar info
-	, global_scalars       = emptyVarSet
-	, global_exported_vars = emptyVarEnv
-	, global_tycons        = mapNameEnv snd $ vectInfoTyCon info
-	, global_datacons      = mapNameEnv snd $ vectInfoDataCon info
-	, global_pa_funs       = mapNameEnv snd $ vectInfoPADFun info
-	, global_pr_funs       = emptyNameEnv
-	, global_boxed_tycons  = emptyNameEnv
-	, global_inst_env      = instEnvs
-	, global_fam_inst_env  = famInstEnvs
-	, global_bindings      = []
-	}
-
+initGlobalEnv :: VectInfo -> [CoreVect] -> (InstEnv, InstEnv) -> FamInstEnvs -> GlobalEnv
+initGlobalEnv info vectDecls instEnvs famInstEnvs
+  = GlobalEnv 
+  { global_vars          = mapVarEnv snd $ vectInfoVar info
+  , global_vect_decls    = mkVarEnv vects
+  , global_scalars       = mkVarSet scalars
+  , global_exported_vars = emptyVarEnv
+  , global_tycons        = mapNameEnv snd $ vectInfoTyCon info
+  , global_datacons      = mapNameEnv snd $ vectInfoDataCon info
+  , global_pa_funs       = mapNameEnv snd $ vectInfoPADFun info
+  , global_pr_funs       = emptyNameEnv
+  , global_boxed_tycons  = emptyNameEnv
+  , global_inst_env      = instEnvs
+  , global_fam_inst_env  = famInstEnvs
+  , global_bindings      = []
+  }
+  where
+    vects   = [(var, (varType var, exp)) | Vect var (Just exp) <- vectDecls]
+    scalars = [var                       | Vect var Nothing    <- vectDecls]
 
 
 -- Operators on Global Environments -------------------------------------------
@@ -135,13 +146,11 @@ extendImportedVarsEnv :: [(Var, Var)] -> GlobalEnv -> GlobalEnv
 extendImportedVarsEnv ps genv
   = genv { global_vars	 = extendVarEnvList (global_vars genv) ps }
 
-
 -- | Extend the set of scalar variables in an environment.
 extendScalars :: [Var] -> GlobalEnv -> GlobalEnv
 extendScalars vs genv
   = genv { global_scalars = extendVarSetList (global_scalars genv) vs }
 
-
 -- | Set the list of type family instances in an environment.
 setFamEnv :: FamInstEnv -> GlobalEnv -> GlobalEnv
 setFamEnv l_fam_inst genv
diff --git a/compiler/vectorise/Vectorise/Exp.hs b/compiler/vectorise/Vectorise/Exp.hs
index 9cd34e3ac3..569057e5e8 100644
--- a/compiler/vectorise/Vectorise/Exp.hs
+++ b/compiler/vectorise/Vectorise/Exp.hs
@@ -33,17 +33,15 @@ import Data.List
 
 
 -- | Vectorise a polymorphic expression.
-vectPolyExpr 
-	:: Bool 		-- ^ When vectorising the RHS of a binding, whether that
-			  	    --   binding is a loop breaker.
-	-> [Var] 			
-	-> CoreExprWithFVs
-	-> VM (Inline, Bool, VExpr)
-
+--
+vectPolyExpr :: Bool 		-- ^ When vectorising the RHS of a binding, whether that
+			  	              --   binding is a loop breaker.
+	           -> [Var] 			
+	           -> CoreExprWithFVs
+	           -> VM (Inline, Bool, VExpr)
 vectPolyExpr loop_breaker recFns (_, AnnNote note expr)
  = do (inline, isScalarFn, expr') <- vectPolyExpr loop_breaker recFns expr
       return (inline, isScalarFn, vNote note expr')
-
 vectPolyExpr loop_breaker recFns expr
  = do
       arity <- polyArity tvs
@@ -148,22 +146,19 @@ onlyIfV (isEmptyVarSet fvs) (vectScalarLam bs $ deAnnotate body)
 
 vectExpr e = cantVectorise "Can't vectorise expression (vectExpr)" (ppr $ deAnnotate e)
 
-
 -- | Vectorise an expression with an outer lambda abstraction.
-vectFnExpr 
-	:: Bool 		-- ^ When the RHS of a binding, whether that binding should be inlined.
-	-> Bool 		-- ^ Whether the binding is a loop breaker.
-	-> [Var]
-	-> CoreExprWithFVs 	-- ^ Expression to vectorise. Must have an outer `AnnLam`.
-	-> VM (Inline, Bool, VExpr)
-
+--
+vectFnExpr :: Bool             -- ^ When the RHS of a binding, whether that binding should be inlined.
+           -> Bool             -- ^ Whether the binding is a loop breaker.
+           -> [Var]
+           -> CoreExprWithFVs  -- ^ Expression to vectorise. Must have an outer `AnnLam`.
+           -> VM (Inline, Bool, VExpr)
 vectFnExpr inline loop_breaker recFns e@(fvs, AnnLam bndr _)
   | isId bndr = onlyIfV True -- (isEmptyVarSet fvs)  -- we check for free variables later. TODO: clean up
                         (mark DontInline True . vectScalarLam bs recFns $ deAnnotate body)
                 `orElseV` mark inlineMe False (vectLam inline loop_breaker fvs bs body)
   where
     (bs,body) = collectAnnValBinders e
-
 vectFnExpr _ _ _  e = mark DontInline False $ vectExpr e
 
 mark :: Inline -> Bool -> VM a -> VM (Inline, Bool, a)
diff --git a/compiler/vectorise/Vectorise/Monad.hs b/compiler/vectorise/Vectorise/Monad.hs
index 259743058e..5fcd2ac088 100644
--- a/compiler/vectorise/Vectorise/Monad.hs
+++ b/compiler/vectorise/Vectorise/Monad.hs
@@ -22,8 +22,8 @@ module Vectorise.Monad (
 	-- * Primitives
 	lookupPrimPArray,
 	lookupPrimMethod
-)
-where
+) where
+
 import Vectorise.Monad.Base
 import Vectorise.Monad.Naming
 import Vectorise.Monad.Local
@@ -32,68 +32,75 @@ import Vectorise.Monad.InstEnv
 import Vectorise.Builtins
 import Vectorise.Env
 
-import HscTypes hiding  ( MonadThings(..) )
+import HscTypes hiding ( MonadThings(..) )
+import DynFlags
 import MonadUtils (liftIO)
-import Module
 import TyCon
 import Var
 import VarEnv
 import Id
 import DsMonad
 import Outputable
+import FastString
+
 import Control.Monad
 import VarSet
 
 -- | Run a vectorisation computation.
-initV	:: PackageId
-	-> HscEnv
-	-> ModGuts
-	-> VectInfo
-	-> VM a
-	-> IO (Maybe (VectInfo, a))
-
-initV pkg hsc_env guts info p
-  = do
-         -- XXX: ignores error messages and warnings, check that this is
-         -- indeed ok (the use of "Just r" suggests so)
-      (_,Just r) <- initDs hsc_env (mg_module guts)
-                               (mg_rdr_env guts)
-                               (mg_types guts)
-                               go
-      return r
+--
+initV :: HscEnv
+      -> ModGuts
+      -> VectInfo
+      -> VM a
+      -> IO (Maybe (VectInfo, a))
+initV hsc_env guts info thing_inside
+  = do { (_, Just r) <- initDs hsc_env (mg_module guts) (mg_rdr_env guts) (mg_types guts) go
+       ; return r
+       }
   where
     go 
-     = do
-        builtins	<- initBuiltins pkg
-        builtin_vars	<- initBuiltinVars builtins
-        builtin_tycons	<- initBuiltinTyCons builtins
-        let builtin_datacons = initBuiltinDataCons builtins
-        builtin_boxed	<- initBuiltinBoxedTyCons builtins
-        builtin_scalars	<- initBuiltinScalars builtins
-
-        eps <- liftIO $ hscEPS hsc_env
-        let famInstEnvs = (eps_fam_inst_env eps, mg_fam_inst_env guts)
-            instEnvs    = (eps_inst_env     eps, mg_inst_env     guts)
-
-        builtin_prs	<- initBuiltinPRs builtins instEnvs
-        builtin_pas	<- initBuiltinPAs builtins instEnvs
-
-        let genv = extendImportedVarsEnv builtin_vars
-                 . extendScalars builtin_scalars
-                 . extendTyConsEnv builtin_tycons
-                 . extendDataConsEnv builtin_datacons
-                 . extendPAFunsEnv builtin_pas
-                 . setPRFunsEnv    builtin_prs
-                 . setBoxedTyConsEnv builtin_boxed
-                 $ initGlobalEnv info instEnvs famInstEnvs
-
-        r <- runVM p builtins genv emptyLocalEnv
-        case r of
-          Yes genv _ x -> return $ Just (new_info genv, x)
-          No           -> return Nothing
+      = do {   -- pick a DPH backend
+           ; dflags <- getDOptsDs
+           ; case dphPackageMaybe dflags of
+               Nothing  -> failWithDs $ ptext selectBackendErr
+               Just pkg -> do {
+
+               -- set up tables of builtin entities
+           ; let compilingDPH = dphBackend dflags == DPHThis  -- FIXME: temporary kludge support
+           ; builtins        <- initBuiltins pkg
+           ; builtin_vars    <- initBuiltinVars compilingDPH builtins
+           ; builtin_tycons  <- initBuiltinTyCons builtins
+           ; let builtin_datacons = initBuiltinDataCons builtins
+           ; builtin_boxed   <- initBuiltinBoxedTyCons builtins
+           ; builtin_scalars <- initBuiltinScalars compilingDPH builtins
+
+               -- set up class and type family envrionments
+           ; eps <- liftIO $ hscEPS hsc_env
+           ; let famInstEnvs = (eps_fam_inst_env eps, mg_fam_inst_env guts)
+                 instEnvs    = (eps_inst_env     eps, mg_inst_env     guts)
+           ; builtin_prs <- initBuiltinPRs builtins instEnvs
+           ; builtin_pas <- initBuiltinPAs builtins instEnvs
+
+               -- construct the initial global environment
+           ; let genv = extendImportedVarsEnv builtin_vars
+                        . extendScalars       builtin_scalars
+                        . extendTyConsEnv     builtin_tycons
+                        . extendDataConsEnv   builtin_datacons
+                        . extendPAFunsEnv     builtin_pas
+                        . setPRFunsEnv        builtin_prs
+                        . setBoxedTyConsEnv   builtin_boxed
+                        $ initGlobalEnv info (mg_vect_decls guts) instEnvs famInstEnvs
+ 
+               -- perform vectorisation
+           ; r <- runVM thing_inside builtins genv emptyLocalEnv
+           ; case r of
+               Yes genv _ x -> return $ Just (new_info genv, x)
+               No           -> return Nothing
+           } }
 
     new_info genv = updVectInfo genv (mg_types guts) info
 
+    selectBackendErr = sLit "To use -fvectorise select a DPH backend with -fdph-par or -fdph-seq"
 
 -- Builtins -------------------------------------------------------------------
 -- | Lift a desugaring computation using the `Builtins` into the vectorisation monad.
@@ -139,17 +146,20 @@ dumpVar var
 	| otherwise
 	= cantVectorise "Variable not vectorised:" (ppr var)
 
--- local scalars --------------------------------------------------------------
--- | Check if the variable is a locally defined scalar function
 
+-- local scalars --------------------------------------------------------------
 
 addGlobalScalar :: Var -> VM ()
 addGlobalScalar var 
-  = updGEnv $ \env -> pprTrace "addGLobalScalar" (ppr var) env{global_scalars = extendVarSet (global_scalars env) var}
+  = do { traceVt "addGlobalScalar" (ppr var)
+       ; updGEnv $ \env -> env{global_scalars = extendVarSet (global_scalars env) var}
+     }
      
 deleteGlobalScalar :: Var -> VM ()
 deleteGlobalScalar var 
-  = updGEnv $ \env -> pprTrace "deleteGLobalScalar" (ppr var) env{global_scalars = delVarSet (global_scalars env) var}
+  = do { traceVt "deleteGlobalScalar" (ppr var)
+       ; updGEnv $ \env -> env{global_scalars = delVarSet (global_scalars env) var}
+     }
      
      
 -- Primitives -----------------------------------------------------------------
diff --git a/compiler/vectorise/Vectorise/Monad/Base.hs b/compiler/vectorise/Vectorise/Monad/Base.hs
index c2c314faf9..aa73e25264 100644
--- a/compiler/vectorise/Vectorise/Monad/Base.hs
+++ b/compiler/vectorise/Vectorise/Monad/Base.hs
@@ -13,6 +13,9 @@ module Vectorise.Monad.Base (
 	maybeCantVectorise,
 	maybeCantVectoriseM,
 	
+	-- * Debugging
+	traceVt, dumpOptVt, dumpVt,
+	
 	-- * Control
 	noV,	 traceNoV,
 	ensureV, traceEnsureV,
@@ -22,14 +25,23 @@ module Vectorise.Monad.Base (
 	orElseV,
 	fixV,
 ) where
+
 import Vectorise.Builtins
 import Vectorise.Env
 
 import DsMonad
+import TcRnMonad
+import ErrUtils
 import Outputable
-	
+import DynFlags
+import StaticFlags
+
+import Control.Monad
+import System.IO (stderr)
+
 
 -- The Vectorisation Monad ----------------------------------------------------
+
 -- | Vectorisation can either succeed with new envionment and a value,
 --   or return with failure.
 data VResult a 
@@ -46,6 +58,12 @@ instance Monad VM where
                                         Yes genv' lenv' x -> runVM (f x) bi genv' lenv'
                                         No                -> return No
 
+instance Functor VM where
+  fmap = liftM
+  
+instance MonadIO VM where
+  liftIO = liftDs . liftIO
+
 
 -- Lifting --------------------------------------------------------------------
 -- | Lift a desugaring computation into the vectorisation monad.
@@ -77,6 +95,36 @@ maybeCantVectoriseM s d p
         Just x  -> return x
         Nothing -> cantVectorise s d
 
+
+-- Debugging ------------------------------------------------------------------
+
+-- |Output a trace message if -ddump-vt-trace is active.
+--
+traceVt :: String -> SDoc -> VM () 
+traceVt herald doc
+  | 1 <= opt_TraceLevel = liftDs $
+                            traceOptIf Opt_D_dump_vt_trace $
+                              hang (text herald) 2 doc
+  | otherwise           = return ()
+
+-- |Dump the given program conditionally.
+--
+dumpOptVt :: DynFlag -> String -> SDoc -> VM ()
+dumpOptVt flag header doc 
+  = do { b <- liftDs $ doptM flag
+       ; if b 
+         then dumpVt header doc 
+         else return () 
+       }
+
+-- |Dump the given program unconditionally.
+--
+dumpVt :: String -> SDoc -> VM ()
+dumpVt header doc 
+  = do { unqual <- liftDs mkPrintUnqualifiedDs
+       ; liftIO $ printForUser stderr unqual (mkDumpDoc header doc)
+       }
+
 -- Control --------------------------------------------------------------------
 -- | Return some result saying we've failed.
 noV :: VM a
diff --git a/compiler/vectorise/Vectorise/Monad/Global.hs b/compiler/vectorise/Vectorise/Monad/Global.hs
index 4bd6c770fd..ae68ffbc5c 100644
--- a/compiler/vectorise/Vectorise/Monad/Global.hs
+++ b/compiler/vectorise/Vectorise/Monad/Global.hs
@@ -4,11 +4,14 @@ module Vectorise.Monad.Global (
 	setGEnv,
 	updGEnv,
 	
-	-- * Vars
-	defGlobalVar,
-	
-	-- * Scalars
-	globalScalars,
+  -- * Vars
+  defGlobalVar,
+  
+  -- * Vectorisation declarations
+  lookupVectDecl,
+  
+  -- * Scalars
+  globalScalars, isGlobalScalar,
 	
 	-- * TyCons
 	lookupTyCon,
@@ -27,8 +30,12 @@ module Vectorise.Monad.Global (
 	-- * PR Dictionaries
 	lookupTyConPR
 ) where
+
 import Vectorise.Monad.Base
 import Vectorise.Env
+
+import CoreSyn
+import Type
 import TyCon
 import DataCon
 import NameEnv
@@ -65,11 +72,20 @@ defGlobalVar v v' = updGEnv $ \env ->
             | otherwise      = env
 
 
+-- Vectorisation declarations -------------------------------------------------
+-- | Check whether a variable has a (non-scalar) vectorisation declaration.
+lookupVectDecl :: Var -> VM (Maybe (Type, CoreExpr))
+lookupVectDecl var = readGEnv $ \env -> lookupVarEnv (global_vect_decls env) var
+
+
 -- Scalars --------------------------------------------------------------------
 -- | Get the set of global scalar variables.
 globalScalars :: VM VarSet
-globalScalars 
-	= readGEnv global_scalars
+globalScalars = readGEnv global_scalars
+
+-- | Check whether a given variable is in the set of global scalar variables.
+isGlobalScalar :: Var -> VM Bool
+isGlobalScalar var = readGEnv $ \env -> elemVarSet var (global_scalars env)
 
 
 -- TyCons ---------------------------------------------------------------------
diff --git a/compiler/vectorise/Vectorise/Type/Env.hs b/compiler/vectorise/Vectorise/Type/Env.hs
index 61a52bc4b7..84844101a3 100644
--- a/compiler/vectorise/Vectorise/Type/Env.hs
+++ b/compiler/vectorise/Vectorise/Type/Env.hs
@@ -1,12 +1,9 @@
-{-# OPTIONS_GHC -fno-warn-missing-signatures #-}
 {-# OPTIONS_GHC -XNoMonoLocalBinds #-}
--- Roman likes local bindings
--- If this module lives on I'd like to get rid of this flag in due course
 
 module Vectorise.Type.Env ( 
 	vectTypeEnv,
-)
-where
+) where
+  
 import Vectorise.Env
 import Vectorise.Vect
 import Vectorise.Monad
@@ -42,20 +39,18 @@ import MonadUtils
 import Control.Monad
 import Data.List
 
-debug		= False
-dtrace s x	= if debug then pprTrace "VectType" s x else x
 
 -- | Vectorise a type environment.
 --   The type environment contains all the type things defined in a module.
-vectTypeEnv 
-	:: TypeEnv
-	-> VM ( TypeEnv			-- Vectorised type environment.
-	      , [FamInst]		-- New type family instances.
-	      , [(Var, CoreExpr)])	-- New top level bindings.
-	
+--
+vectTypeEnv :: TypeEnv
+            -> VM ( TypeEnv             -- Vectorised type environment.
+                  , [FamInst]           -- New type family instances.
+                  , [(Var, CoreExpr)])  -- New top level bindings.
 vectTypeEnv env
- = dtrace (ppr env)
- $ do
+  = do
+      traceVt "** vectTypeEnv" $ ppr env
+      
       cs <- readGEnv $ mk_map . global_tycons
 
       -- Split the list of TyCons into the ones we have to vectorise vs the
@@ -122,14 +117,11 @@ vectTypeEnv env
    where
     mk_map env = listToUFM_Directly [(u, getUnique n /= u) | (u,n) <- nameEnvUniqueElts env]
 
-
-
 buildTyConBindings :: TyCon -> TyCon -> TyCon -> TyCon -> SumRepr -> VM Var
 buildTyConBindings orig_tc vect_tc prepr_tc pdata_tc repr
  = do vectDataConWorkers orig_tc vect_tc pdata_tc
       buildPADict vect_tc prepr_tc pdata_tc repr
 
-
 vectDataConWorkers :: TyCon -> TyCon -> TyCon -> VM ()
 vectDataConWorkers orig_tc vect_tc arr_tc
  = do bs <- sequence
diff --git a/compiler/vectorise/Vectorise/Type/Type.hs b/compiler/vectorise/Vectorise/Type/Type.hs
index e62f45acb2..8cc2bec519 100644
--- a/compiler/vectorise/Vectorise/Type/Type.hs
+++ b/compiler/vectorise/Vectorise/Type/Type.hs
@@ -33,7 +33,7 @@ vectAndLiftType :: Type -> VM (Type, Type)
 vectAndLiftType ty | Just ty' <- coreView ty = vectAndLiftType ty'
 vectAndLiftType ty
   = do
-      mdicts   <- mapM paDictArgType tyvars
+      mdicts   <- mapM paDictArgType (reverse tyvars)
       let dicts = [dict | Just dict <- mdicts]
       vmono_ty <- vectType mono_ty
       lmono_ty <- mkPDataType vmono_ty
@@ -78,7 +78,8 @@ vectType ty@(ForAllTy _ _)
       dictsPA     <- liftM catMaybes $ mapM paDictArgType tyvars
 
       -- pack it all back together.
-      return $ abstractType tyvars (dictsVect ++ dictsPA) tyBody''
+      traceVt "vect ForAllTy: " $ ppr (abstractType tyvars (dictsPA ++ dictsVect) tyBody'')
+      return $ abstractType tyvars (dictsPA ++ dictsVect) tyBody''
 
 vectType ty = cantVectorise "Can't vectorise type" (ppr ty)