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

diff --git a/compiler/coreSyn/CoreSyn.lhs b/compiler/coreSyn/CoreSyn.lhs
index 7bc4c44..603b745 100644 (file)
--- a/compiler/coreSyn/CoreSyn.lhs
+++ b/compiler/coreSyn/CoreSyn.lhs
@@ -72,7 +72,10 @@ module CoreSyn (
        -- ** Operations on 'CoreRule's 
        seqRules, ruleArity, ruleName, ruleIdName, ruleActivation,
        setRuleIdName,
        -- ** Operations on 'CoreRule's 
        seqRules, ruleArity, ruleName, ruleIdName, ruleActivation,
        setRuleIdName,

-       isBuiltinRule, isLocalRule
+       isBuiltinRule, isLocalRule,
+
+       -- * Core vectorisation declarations data type
+       CoreVect(..)

     ) where
 
 #include "HsVersions.h"
     ) where
 
 #include "HsVersions.h"

@@ -402,6 +405,20 @@ setRuleIdName nm ru = ru { ru_fn = nm }
 
 
 %************************************************************************
 
 
 %************************************************************************

+%*                                                                      *
+\subsection{Vectorisation declarations}
+%*                                                                      *
+%************************************************************************
+
+Representation of desugared vectorisation declarations that are fed to the vectoriser (via
+'ModGuts').
+
+\begin{code}
+data CoreVect = Vect Id (Maybe CoreExpr)
+\end{code}
+
+
+%************************************************************************

 %*                                                                     *
                Unfoldings
 %*                                                                     *
 %*                                                                     *
                Unfoldings
 %*                                                                     *

diff --git a/compiler/deSugar/Desugar.lhs b/compiler/deSugar/Desugar.lhs
index 60dec30..142f695 100644 (file)
--- a/compiler/deSugar/Desugar.lhs
+++ b/compiler/deSugar/Desugar.lhs
@@ -69,12 +69,13 @@ deSugar hsc_env
                            tcg_anns         = anns,
                            tcg_binds        = binds,
                            tcg_imp_specs    = imp_specs,
                            tcg_anns         = anns,
                            tcg_binds        = binds,
                            tcg_imp_specs    = imp_specs,

-                           tcg_ev_binds     = ev_binds,
-                           tcg_fords        = fords,
-                           tcg_rules        = rules,
-                           tcg_insts        = insts,
-                           tcg_fam_insts    = fam_insts,
-                           tcg_hpc          = other_hpc_info })
+                            tcg_ev_binds     = ev_binds,
+                            tcg_fords        = fords,
+                            tcg_rules        = rules,
+                            tcg_vects        = vects,
+                            tcg_insts        = insts,
+                            tcg_fam_insts    = fam_insts,
+                            tcg_hpc          = other_hpc_info })

 
   = do { let dflags = hsc_dflags hsc_env
         ; showPass dflags "Desugar"
 
   = do { let dflags = hsc_dflags hsc_env
         ; showPass dflags "Desugar"

@@ -88,7 +89,7 @@ deSugar hsc_env
               <- case target of
                   HscNothing ->
                        return (emptyMessages,
               <- case target of
                   HscNothing ->
                        return (emptyMessages,

-                               Just ([], nilOL, [], NoStubs, hpcInfo, emptyModBreaks))
+                               Just ([], nilOL, [], [], NoStubs, hpcInfo, emptyModBreaks))

                    _        -> do
                      (binds_cvr,ds_hpc_info, modBreaks)
                         <- if (opt_Hpc
                    _        -> do
                      (binds_cvr,ds_hpc_info, modBreaks)
                         <- if (opt_Hpc

@@ -98,19 +99,20 @@ deSugar hsc_env
                                                            (typeEnvTyCons type_env) binds 
                               else return (binds, hpcInfo, emptyModBreaks)
                      initDs hsc_env mod rdr_env type_env $ do
                                                            (typeEnvTyCons type_env) binds 
                               else return (binds, hpcInfo, emptyModBreaks)
                      initDs hsc_env mod rdr_env type_env $ do

-                      do { ds_ev_binds <- dsEvBinds ev_binds
-                         ; core_prs <- dsTopLHsBinds auto_scc binds_cvr
+                       do { ds_ev_binds <- dsEvBinds ev_binds
+                          ; core_prs <- dsTopLHsBinds auto_scc binds_cvr

                           ; (spec_prs, spec_rules) <- dsImpSpecs imp_specs
                           ; (spec_prs, spec_rules) <- dsImpSpecs imp_specs

-                         ; (ds_fords, foreign_prs) <- dsForeigns fords
-                         ; rules <- mapMaybeM dsRule rules
-                         ; return ( ds_ev_binds
+                          ; (ds_fords, foreign_prs) <- dsForeigns fords
+                          ; ds_rules <- mapMaybeM dsRule rules
+                          ; ds_vects <- mapM dsVect vects
+                          ; return ( ds_ev_binds

                                    , foreign_prs `appOL` core_prs `appOL` spec_prs
                                    , foreign_prs `appOL` core_prs `appOL` spec_prs

-                                   , spec_rules ++ rules
+                                   , spec_rules ++ ds_rules, ds_vects

                                    , ds_fords, ds_hpc_info, modBreaks) }
 
                                    , ds_fords, ds_hpc_info, modBreaks) }
 

-       ; case mb_res of {
-          Nothing -> return (msgs, Nothing) ;
-          Just (ds_ev_binds, all_prs, all_rules, ds_fords,ds_hpc_info, modBreaks) -> do
+        ; case mb_res of {
+           Nothing -> return (msgs, Nothing) ;
+           Just (ds_ev_binds, all_prs, all_rules, ds_vects, ds_fords,ds_hpc_info, modBreaks) -> do

 
        {       -- Add export flags to bindings
          keep_alive <- readIORef keep_var
 
        {       -- Add export flags to bindings
          keep_alive <- readIORef keep_var

@@ -161,6 +163,7 @@ deSugar hsc_env
                mg_foreign      = ds_fords,
                mg_hpc_info     = ds_hpc_info,
                 mg_modBreaks    = modBreaks,
                mg_foreign      = ds_fords,
                mg_hpc_info     = ds_hpc_info,
                 mg_modBreaks    = modBreaks,

+                mg_vect_decls   = ds_vects,

                 mg_vect_info    = noVectInfo
               }
         ; return (msgs, Just mod_guts)
                 mg_vect_info    = noVectInfo
               }
         ; return (msgs, Just mod_guts)

@@ -374,3 +377,26 @@ That keeps the desugaring of list comprehensions simple too.
 Nor do we want to warn of conversion identities on the LHS;
 the rule is precisly to optimise them:
   {-# RULES "fromRational/id" fromRational = id :: Rational -> Rational #-}
 Nor do we want to warn of conversion identities on the LHS;
 the rule is precisly to optimise them:
   {-# RULES "fromRational/id" fromRational = id :: Rational -> Rational #-}

+
+
+%************************************************************************
+%*                                                                      *
+%*              Desugaring vectorisation declarations
+%*                                                                      *
+%************************************************************************
+
+\begin{code}
+dsVect :: LVectDecl Id -> DsM CoreVect
+dsVect (L loc (HsVect v rhs))
+  = putSrcSpanDs loc $ 
+    do { rhs' <- fmapMaybeM dsLExpr rhs
+       ; return $ Vect (unLoc v) rhs'
+          }
+-- dsVect (L loc (HsVect v Nothing))
+--   = return $ Vect v Nothing
+-- dsVect (L loc (HsVect v (Just rhs)))
+--   = putSrcSpanDs loc $ 
+--     do { rhs' <- dsLExpr rhs
+--        ; return $ Vect v (Just rhs')
+--       }
+\end{code}

diff --git a/compiler/deSugar/DsExpr.lhs b/compiler/deSugar/DsExpr.lhs
index 4084310..1781aef 100644 (file)
--- a/compiler/deSugar/DsExpr.lhs
+++ b/compiler/deSugar/DsExpr.lhs
@@ -368,11 +368,11 @@ dsExpr (ExplicitList elt_ty xs)
 --   singletonP x1 +:+ ... +:+ singletonP xn
 --
 dsExpr (ExplicitPArr ty []) = do
 --   singletonP x1 +:+ ... +:+ singletonP xn
 --
 dsExpr (ExplicitPArr ty []) = do

-    emptyP <- dsLookupGlobalId emptyPName
+    emptyP <- dsLookupDPHId emptyPName

     return (Var emptyP `App` Type ty)
 dsExpr (ExplicitPArr ty xs) = do
     return (Var emptyP `App` Type ty)
 dsExpr (ExplicitPArr ty xs) = do

-    singletonP <- dsLookupGlobalId singletonPName
-    appP       <- dsLookupGlobalId appPName
+    singletonP <- dsLookupDPHId singletonPName
+    appP       <- dsLookupDPHId appPName

     xs'        <- mapM dsLExpr xs
     return . foldr1 (binary appP) $ map (unary singletonP) xs'
   where
     xs'        <- mapM dsLExpr xs
     return . foldr1 (binary appP) $ map (unary singletonP) xs'
   where

diff --git a/compiler/deSugar/DsListComp.lhs b/compiler/deSugar/DsListComp.lhs
index 2292aed..cd22b8f 100644 (file)
--- a/compiler/deSugar/DsListComp.lhs
+++ b/compiler/deSugar/DsListComp.lhs
@@ -514,7 +514,7 @@ dsPArrComp [ParStmt qss] body _  =  -- parallel comprehension
 --    <<[:e' | qs:]>> p (filterP (\x -> case x of {p -> True; _ -> False}) e)
 --
 dsPArrComp (BindStmt p e _ _ : qs) body _ = do
 --    <<[:e' | qs:]>> p (filterP (\x -> case x of {p -> True; _ -> False}) e)
 --
 dsPArrComp (BindStmt p e _ _ : qs) body _ = do

-    filterP <- dsLookupGlobalId filterPName
+    filterP <- dsLookupDPHId filterPName

     ce <- dsLExpr e
     let ety'ce  = parrElemType ce
         false   = Var falseDataConId
     ce <- dsLExpr e
     let ety'ce  = parrElemType ce
         false   = Var falseDataConId

@@ -526,7 +526,7 @@ dsPArrComp (BindStmt p e _ _ : qs) body _ = do
     dePArrComp qs body p gen
 
 dsPArrComp qs            body _  = do -- no ParStmt in `qs'
     dePArrComp qs body p gen
 
 dsPArrComp qs            body _  = do -- no ParStmt in `qs'

-    sglP <- dsLookupGlobalId singletonPName
+    sglP <- dsLookupDPHId singletonPName

     let unitArray = mkApps (Var sglP) [Type unitTy, mkCoreTup []]
     dePArrComp qs body (noLoc $ WildPat unitTy) unitArray
 
     let unitArray = mkApps (Var sglP) [Type unitTy, mkCoreTup []]
     dePArrComp qs body (noLoc $ WildPat unitTy) unitArray
 

@@ -543,7 +543,7 @@ dePArrComp :: [Stmt Id]
 --  <<[:e' | :]>> pa ea = mapP (\pa -> e') ea
 --
 dePArrComp [] e' pa cea = do
 --  <<[:e' | :]>> pa ea = mapP (\pa -> e') ea
 --
 dePArrComp [] e' pa cea = do

-    mapP <- dsLookupGlobalId mapPName
+    mapP <- dsLookupDPHId mapPName

     let ty = parrElemType cea
     (clam, ty'e') <- deLambda ty pa e'
     return $ mkApps (Var mapP) [Type ty, Type ty'e', clam, cea]
     let ty = parrElemType cea
     (clam, ty'e') <- deLambda ty pa e'
     return $ mkApps (Var mapP) [Type ty, Type ty'e', clam, cea]

@@ -551,7 +551,7 @@ dePArrComp [] e' pa cea = do
 --  <<[:e' | b, qs:]>> pa ea = <<[:e' | qs:]>> pa (filterP (\pa -> b) ea)
 --
 dePArrComp (ExprStmt b _ _ : qs) body pa cea = do
 --  <<[:e' | b, qs:]>> pa ea = <<[:e' | qs:]>> pa (filterP (\pa -> b) ea)
 --
 dePArrComp (ExprStmt b _ _ : qs) body pa cea = do

-    filterP <- dsLookupGlobalId filterPName
+    filterP <- dsLookupDPHId filterPName

     let ty = parrElemType cea
     (clam,_) <- deLambda ty pa b
     dePArrComp qs body pa (mkApps (Var filterP) [Type ty, clam, cea])
     let ty = parrElemType cea
     (clam,_) <- deLambda ty pa b
     dePArrComp qs body pa (mkApps (Var filterP) [Type ty, clam, cea])

@@ -570,8 +570,8 @@ dePArrComp (ExprStmt b _ _ : qs) body pa cea = do
 --    <<[:e' | qs:]>> (pa, p) (crossMapP ea ef)
 --
 dePArrComp (BindStmt p e _ _ : qs) body pa cea = do
 --    <<[:e' | qs:]>> (pa, p) (crossMapP ea ef)
 --
 dePArrComp (BindStmt p e _ _ : qs) body pa cea = do

-    filterP <- dsLookupGlobalId filterPName
-    crossMapP <- dsLookupGlobalId crossMapPName
+    filterP <- dsLookupDPHId filterPName
+    crossMapP <- dsLookupDPHId crossMapPName

     ce <- dsLExpr e
     let ety'cea = parrElemType cea
         ety'ce  = parrElemType ce
     ce <- dsLExpr e
     let ety'cea = parrElemType cea
         ety'ce  = parrElemType ce

@@ -595,7 +595,7 @@ dePArrComp (BindStmt p e _ _ : qs) body pa cea = do
 --    {x_1, ..., x_n} = DV (ds)                -- Defined Variables
 --
 dePArrComp (LetStmt ds : qs) body pa cea = do
 --    {x_1, ..., x_n} = DV (ds)                -- Defined Variables
 --
 dePArrComp (LetStmt ds : qs) body pa cea = do

-    mapP <- dsLookupGlobalId mapPName
+    mapP <- dsLookupDPHId mapPName

     let xs     = collectLocalBinders ds
         ty'cea = parrElemType cea
     v <- newSysLocalDs ty'cea
     let xs     = collectLocalBinders ds
         ty'cea = parrElemType cea
     v <- newSysLocalDs ty'cea

@@ -640,7 +640,7 @@ dePArrParComp qss body = do
     ---
     parStmts []             pa cea = return (pa, cea)
     parStmts ((qs, xs):qss) pa cea = do  -- subsequent statements (zip'ed)
     ---
     parStmts []             pa cea = return (pa, cea)
     parStmts ((qs, xs):qss) pa cea = do  -- subsequent statements (zip'ed)

-      zipP <- dsLookupGlobalId zipPName
+      zipP <- dsLookupDPHId zipPName

       let pa'      = mkLHsPatTup [pa, mkLHsVarPatTup xs]
           ty'cea   = parrElemType cea
           res_expr = mkLHsVarTuple xs
       let pa'      = mkLHsPatTup [pa, mkLHsVarPatTup xs]
           ty'cea   = parrElemType cea
           res_expr = mkLHsVarTuple xs

diff --git a/compiler/deSugar/DsMonad.lhs b/compiler/deSugar/DsMonad.lhs
index 1238b1a..62e8053 100644 (file)
--- a/compiler/deSugar/DsMonad.lhs
+++ b/compiler/deSugar/DsMonad.lhs
@@ -12,15 +12,16 @@ module DsMonad (
        foldlM, foldrM, ifDOptM, unsetOptM,
        Applicative(..),(<$>),
 
        foldlM, foldrM, ifDOptM, unsetOptM,
        Applicative(..),(<$>),
 

-       newLocalName,
-       duplicateLocalDs, newSysLocalDs, newSysLocalsDs, newUniqueId,
-       newFailLocalDs, newPredVarDs,
-       getSrcSpanDs, putSrcSpanDs,
-       getModuleDs,
-       newUnique, 
-       UniqSupply, newUniqueSupply,
-       getDOptsDs, getGhcModeDs, doptDs,
-       dsLookupGlobal, dsLookupGlobalId, dsLookupTyCon, dsLookupDataCon,
+        newLocalName,
+        duplicateLocalDs, newSysLocalDs, newSysLocalsDs, newUniqueId,
+        newFailLocalDs, newPredVarDs,
+        getSrcSpanDs, putSrcSpanDs,
+        getModuleDs,
+        mkPrintUnqualifiedDs,
+        newUnique, 
+        UniqSupply, newUniqueSupply,
+        getDOptsDs, getGhcModeDs, doptDs,
+        dsLookupGlobal, dsLookupGlobalId, dsLookupDPHId, dsLookupTyCon, dsLookupDataCon,

         dsLookupClass,
 
        DsMetaEnv, DsMetaVal(..), dsLookupMetaEnv, dsExtendMetaEnv,
         dsLookupClass,
 
        DsMetaEnv, DsMetaVal(..), dsLookupMetaEnv, dsExtendMetaEnv,

@@ -282,6 +283,9 @@ failWithDs err
        ; let msg = mkErrMsg loc (ds_unqual env) err
        ; updMutVar (ds_msgs env) (\ (w,e) -> (w, e `snocBag` msg))
        ; failM }
        ; let msg = mkErrMsg loc (ds_unqual env) err
        ; updMutVar (ds_msgs env) (\ (w,e) -> (w, e `snocBag` msg))
        ; failM }

+
+mkPrintUnqualifiedDs :: DsM PrintUnqualified
+mkPrintUnqualifiedDs = ds_unqual <$> getGblEnv

 \end{code}
 
 \begin{code}
 \end{code}
 
 \begin{code}

@@ -299,6 +303,19 @@ dsLookupGlobalId :: Name -> DsM Id
 dsLookupGlobalId name 
   = tyThingId <$> dsLookupGlobal name
 
 dsLookupGlobalId name 
   = tyThingId <$> dsLookupGlobal name
 

+-- Looking up a global DPH 'Id' is like 'dsLookupGlobalId', but the package, in which the looked
+-- up name is located, varies with the active DPH backend.
+--
+dsLookupDPHId :: (PackageId -> Name) -> DsM Id
+dsLookupDPHId nameInPkg
+  = do { dflags <- getDOpts
+       ; case dphPackageMaybe dflags of
+           Just pkg -> tyThingId <$> dsLookupGlobal (nameInPkg pkg)
+           Nothing  -> failWithDs $ ptext err
+       }
+  where
+    err = sLit "To use -XParallelArrays select a DPH backend with -fdph-par or -fdph-seq"
+

 dsLookupTyCon :: Name -> DsM TyCon
 dsLookupTyCon name
   = tyThingTyCon <$> dsLookupGlobal name
 dsLookupTyCon :: Name -> DsM TyCon
 dsLookupTyCon name
   = tyThingTyCon <$> dsLookupGlobal name

diff --git a/compiler/deSugar/DsUtils.lhs b/compiler/deSugar/DsUtils.lhs
index a4a9b80..3a97687 100644 (file)
--- a/compiler/deSugar/DsUtils.lhs
+++ b/compiler/deSugar/DsUtils.lhs
@@ -383,7 +383,7 @@ mkCoAlgCaseMatchResult var ty match_alts
     isPArrFakeAlts [] = panic "DsUtils: unexpectedly found an empty list of PArr fake alternatives"
     --
     mk_parrCase fail = do
     isPArrFakeAlts [] = panic "DsUtils: unexpectedly found an empty list of PArr fake alternatives"
     --
     mk_parrCase fail = do

-      lengthP <- dsLookupGlobalId lengthPName
+      lengthP <- dsLookupDPHId lengthPName

       alt <- unboxAlt
       return (mkWildCase (len lengthP) intTy ty [alt])
       where
       alt <- unboxAlt
       return (mkWildCase (len lengthP) intTy ty [alt])
       where

@@ -395,7 +395,7 @@ mkCoAlgCaseMatchResult var ty match_alts
        --
        unboxAlt = do
          l      <- newSysLocalDs intPrimTy
        --
        unboxAlt = do
          l      <- newSysLocalDs intPrimTy

-         indexP <- dsLookupGlobalId indexPName
+         indexP <- dsLookupDPHId indexPName

          alts   <- mapM (mkAlt indexP) sorted_alts
          return (DataAlt intDataCon, [l], mkWildCase (Var l) intPrimTy ty (dft : alts))
           where
          alts   <- mapM (mkAlt indexP) sorted_alts
          return (DataAlt intDataCon, [l], mkWildCase (Var l) intPrimTy ty (dft : alts))
           where

diff --git a/compiler/hsSyn/HsBinds.lhs b/compiler/hsSyn/HsBinds.lhs
index 2544515..e080bee 100644 (file)
--- a/compiler/hsSyn/HsBinds.lhs
+++ b/compiler/hsSyn/HsBinds.lhs
@@ -621,10 +621,10 @@ data Sig name     -- Signatures and pragmas
                                -- If it's just defaultInlinePragma, then we said
                                --    SPECIALISE, not SPECIALISE_INLINE
 
                                -- If it's just defaultInlinePragma, then we said
                                --    SPECIALISE, not SPECIALISE_INLINE
 

-       -- A specialisation pragma for instance declarations only
-       -- {-# SPECIALISE instance Eq [Int] #-}
-  | SpecInstSig (LHsType name) -- (Class tys); should be a specialisation of the 
-                               -- current instance decl
+        -- A specialisation pragma for instance declarations only
+        -- {-# SPECIALISE instance Eq [Int] #-}
+  | SpecInstSig (LHsType name)  -- (Class tys); should be a specialisation of the 
+                                -- current instance decl

   deriving (Data, Typeable)
 
 
   deriving (Data, Typeable)
 
 

diff --git a/compiler/hsSyn/HsDecls.lhs b/compiler/hsSyn/HsDecls.lhs
index 8827f3a..345ec32 100644 (file)
--- a/compiler/hsSyn/HsDecls.lhs
+++ b/compiler/hsSyn/HsDecls.lhs
@@ -34,6 +34,8 @@ module HsDecls (
   -- ** @RULE@ declarations
   RuleDecl(..), LRuleDecl, RuleBndr(..),
   collectRuleBndrSigTys,
   -- ** @RULE@ declarations
   RuleDecl(..), LRuleDecl, RuleBndr(..),
   collectRuleBndrSigTys,

+  -- ** @VECTORISE@ declarations
+  VectDecl(..), LVectDecl,

   -- ** @default@ declarations
   DefaultDecl(..), LDefaultDecl,
   -- ** Top-level template haskell splice
   -- ** @default@ declarations
   DefaultDecl(..), LDefaultDecl,
   -- ** Top-level template haskell splice

@@ -57,7 +59,7 @@ module HsDecls (
     ) where
 
 -- friends:
     ) where
 
 -- friends:

-import {-# SOURCE #-}  HsExpr( HsExpr, pprExpr )
+import {-# SOURCE #-}  HsExpr( LHsExpr, HsExpr, pprExpr )

        -- Because Expr imports Decls via HsBracket
 
 import HsBinds
        -- Because Expr imports Decls via HsBracket
 
 import HsBinds

@@ -102,6 +104,7 @@ data HsDecl id
   | WarningD   (WarnDecl id)
   | AnnD       (AnnDecl id)
   | RuleD      (RuleDecl id)
   | WarningD   (WarnDecl id)
   | AnnD       (AnnDecl id)
   | RuleD      (RuleDecl id)

+  | VectD      (VectDecl id)

   | SpliceD    (SpliceDecl id)
   | DocD       (DocDecl)
   | QuasiQuoteD        (HsQuasiQuote id)
   | SpliceD    (SpliceDecl id)
   | DocD       (DocDecl)
   | QuasiQuoteD        (HsQuasiQuote id)

@@ -139,13 +142,14 @@ data HsGroup id
                -- Snaffled out of both top-level fixity signatures,
                -- and those in class declarations
 
                -- Snaffled out of both top-level fixity signatures,
                -- and those in class declarations
 

-       hs_defds  :: [LDefaultDecl id],
-       hs_fords  :: [LForeignDecl id],
-       hs_warnds :: [LWarnDecl id],
-       hs_annds   :: [LAnnDecl id],
-       hs_ruleds :: [LRuleDecl id],
+        hs_defds  :: [LDefaultDecl id],
+        hs_fords  :: [LForeignDecl id],
+        hs_warnds :: [LWarnDecl id],
+        hs_annds  :: [LAnnDecl id],
+        hs_ruleds :: [LRuleDecl id],
+        hs_vects  :: [LVectDecl id],

 
 

-       hs_docs   :: [LDocDecl]
+        hs_docs   :: [LDocDecl]

   } deriving (Data, Typeable)
 
 emptyGroup, emptyRdrGroup, emptyRnGroup :: HsGroup a
   } deriving (Data, Typeable)
 
 emptyGroup, emptyRdrGroup, emptyRnGroup :: HsGroup a

@@ -154,49 +158,52 @@ emptyRnGroup  = emptyGroup { hs_valds = emptyValBindsOut }
 
 emptyGroup = HsGroup { hs_tyclds = [], hs_instds = [], hs_derivds = [],
                       hs_fixds = [], hs_defds = [], hs_annds = [],
 
 emptyGroup = HsGroup { hs_tyclds = [], hs_instds = [], hs_derivds = [],
                       hs_fixds = [], hs_defds = [], hs_annds = [],

-                      hs_fords = [], hs_warnds = [], hs_ruleds = [],
+                      hs_fords = [], hs_warnds = [], hs_ruleds = [], hs_vects = [],

                       hs_valds = error "emptyGroup hs_valds: Can't happen",
                        hs_docs = [] }
 
 appendGroups :: HsGroup a -> HsGroup a -> HsGroup a
 appendGroups 
     HsGroup { 
                       hs_valds = error "emptyGroup hs_valds: Can't happen",
                        hs_docs = [] }
 
 appendGroups :: HsGroup a -> HsGroup a -> HsGroup a
 appendGroups 
     HsGroup { 

-       hs_valds  = val_groups1,
-       hs_tyclds = tyclds1, 
-       hs_instds = instds1,
+        hs_valds  = val_groups1,
+        hs_tyclds = tyclds1, 
+        hs_instds = instds1,

         hs_derivds = derivds1,
         hs_derivds = derivds1,

-       hs_fixds  = fixds1, 
-       hs_defds  = defds1,
-       hs_annds  = annds1,
-       hs_fords  = fords1, 
-       hs_warnds = warnds1,
-       hs_ruleds = rulds1,
+        hs_fixds  = fixds1, 
+        hs_defds  = defds1,
+        hs_annds  = annds1,
+        hs_fords  = fords1, 
+        hs_warnds = warnds1,
+        hs_ruleds = rulds1,
+        hs_vects = vects1,

   hs_docs   = docs1 }
     HsGroup { 
   hs_docs   = docs1 }
     HsGroup { 

-       hs_valds  = val_groups2,
-       hs_tyclds = tyclds2, 
-       hs_instds = instds2,
+        hs_valds  = val_groups2,
+        hs_tyclds = tyclds2, 
+        hs_instds = instds2,

         hs_derivds = derivds2,
         hs_derivds = derivds2,

-       hs_fixds  = fixds2, 
-       hs_defds  = defds2,
-       hs_annds  = annds2,
-       hs_fords  = fords2, 
-       hs_warnds = warnds2,
-       hs_ruleds = rulds2,
-  hs_docs   = docs2 }
+        hs_fixds  = fixds2, 
+        hs_defds  = defds2,
+        hs_annds  = annds2,
+        hs_fords  = fords2, 
+        hs_warnds = warnds2,
+        hs_ruleds = rulds2,
+        hs_vects  = vects2,
+        hs_docs   = docs2 }

   = 
     HsGroup { 
   = 
     HsGroup { 

-       hs_valds  = val_groups1 `plusHsValBinds` val_groups2,
-       hs_tyclds = tyclds1 ++ tyclds2, 
-       hs_instds = instds1 ++ instds2,
+        hs_valds  = val_groups1 `plusHsValBinds` val_groups2,
+        hs_tyclds = tyclds1 ++ tyclds2, 
+        hs_instds = instds1 ++ instds2,

         hs_derivds = derivds1 ++ derivds2,
         hs_derivds = derivds1 ++ derivds2,

-       hs_fixds  = fixds1 ++ fixds2,
-       hs_annds  = annds1 ++ annds2,
-       hs_defds  = defds1 ++ defds2,
-       hs_fords  = fords1 ++ fords2, 
-       hs_warnds = warnds1 ++ warnds2,
-       hs_ruleds = rulds1 ++ rulds2,
-  hs_docs   = docs1  ++ docs2 }
+        hs_fixds  = fixds1 ++ fixds2,
+        hs_annds  = annds1 ++ annds2,
+        hs_defds  = defds1 ++ defds2,
+        hs_fords  = fords1 ++ fords2, 
+        hs_warnds = warnds1 ++ warnds2,
+        hs_ruleds = rulds1 ++ rulds2,
+        hs_vects  = vects1 ++ vects2,
+        hs_docs   = docs1  ++ docs2 }

 \end{code}
 
 \begin{code}
 \end{code}
 
 \begin{code}

@@ -209,6 +216,7 @@ instance OutputableBndr name => Outputable (HsDecl name) where
     ppr (ForD fd)               = ppr fd
     ppr (SigD sd)               = ppr sd
     ppr (RuleD rd)              = ppr rd
     ppr (ForD fd)               = ppr fd
     ppr (SigD sd)               = ppr sd
     ppr (RuleD rd)              = ppr rd

+    ppr (VectD vect)            = ppr vect

     ppr (WarningD wd)           = ppr wd
     ppr (AnnD ad)               = ppr ad
     ppr (SpliceD dd)            = ppr dd
     ppr (WarningD wd)           = ppr wd
     ppr (AnnD ad)               = ppr ad
     ppr (SpliceD dd)            = ppr dd

@@ -225,11 +233,13 @@ instance OutputableBndr name => Outputable (HsGroup name) where
                   hs_annds  = ann_decls,
                   hs_fords  = foreign_decls,
                   hs_defds  = default_decls,
                   hs_annds  = ann_decls,
                   hs_fords  = foreign_decls,
                   hs_defds  = default_decls,

-                  hs_ruleds = rule_decls })
+                  hs_ruleds = rule_decls,
+                  hs_vects  = vect_decls })

        = vcat_mb empty 
             [ppr_ds fix_decls, ppr_ds default_decls, 
             ppr_ds deprec_decls, ppr_ds ann_decls,
             ppr_ds rule_decls,
        = vcat_mb empty 
             [ppr_ds fix_decls, ppr_ds default_decls, 
             ppr_ds deprec_decls, ppr_ds ann_decls,
             ppr_ds rule_decls,

+            ppr_ds vect_decls,

             if isEmptyValBinds val_decls 
                 then Nothing 
                 else Just (ppr val_decls),
             if isEmptyValBinds val_decls 
                 then Nothing 
                 else Just (ppr val_decls),

@@ -996,6 +1006,47 @@ instance OutputableBndr name => Outputable (RuleBndr name) where
    ppr (RuleBndrSig name ty) = ppr name <> dcolon <> ppr ty
 \end{code}
 
    ppr (RuleBndrSig name ty) = ppr name <> dcolon <> ppr ty
 \end{code}
 

+
+%************************************************************************
+%*                                                                      *
+\subsection{Vectorisation declarations}
+%*                                                                      *
+%************************************************************************
+
+A vectorisation pragma
+
+  {-# VECTORISE f = closure1 g (scalar_map g) #-} OR
+  {-# VECTORISE SCALAR f #-}
+  
+Note [Typechecked vectorisation pragmas]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+In case of the first variant of vectorisation pragmas (with an explicit expression),
+we need to infer the type of that expression during type checking and then keep that type
+around until vectorisation, so that it can be checked against the *vectorised* type of 'f'.
+(We cannot determine vectorised types during type checking due to internal information of
+the vectoriser being needed.)
+
+To this end, we annotate the 'Id' of 'f' (the variable mentioned in the PRAGMA) with the
+inferred type of the expression.  This is slightly dodgy, as this is really the type of
+'$v_f' (the name of the vectorised function).
+
+\begin{code}
+type LVectDecl name = Located (VectDecl name)
+
+data VectDecl name
+  = HsVect
+      (Located name)
+      (Maybe (LHsExpr name))    -- 'Nothing' => SCALAR declaration
+  deriving (Data, Typeable)
+      
+instance OutputableBndr name => Outputable (VectDecl name) where
+  ppr (HsVect v rhs)
+    = sep [text "{-# VECTORISE" <+> ppr v,
+           nest 4 (case rhs of
+                     Nothing  -> text "SCALAR #-}"
+                     Just rhs -> pprExpr (unLoc rhs) <+> text "#-}") ]
+\end{code}
+

 %************************************************************************
 %*                                                                     *
 \subsection[DocDecl]{Document comments}
 %************************************************************************
 %*                                                                     *
 \subsection[DocDecl]{Document comments}

diff --git a/compiler/hsSyn/HsUtils.lhs b/compiler/hsSyn/HsUtils.lhs
index 3ef4bff..bf75f4c 100644 (file)
--- a/compiler/hsSyn/HsUtils.lhs
+++ b/compiler/hsSyn/HsUtils.lhs
@@ -20,7 +20,7 @@ module HsUtils(
   mkSimpleMatch, unguardedGRHSs, unguardedRHS, 
   mkMatchGroup, mkMatch, mkHsLam, mkHsIf,
   mkHsWrap, mkLHsWrap, mkHsWrapCoI, mkLHsWrapCoI,
   mkSimpleMatch, unguardedGRHSs, unguardedRHS, 
   mkMatchGroup, mkMatch, mkHsLam, mkHsIf,
   mkHsWrap, mkLHsWrap, mkHsWrapCoI, mkLHsWrapCoI,

-  coiToHsWrapper, mkHsDictLet,
+  coiToHsWrapper, mkHsLams, mkHsDictLet,

   mkHsOpApp, mkHsDo, mkHsWrapPat, mkHsWrapPatCoI,
 
   nlHsTyApp, nlHsVar, nlHsLit, nlHsApp, nlHsApps, nlHsIntLit, nlHsVarApps, 
   mkHsOpApp, mkHsDo, mkHsWrapPat, mkHsWrapPatCoI,
 
   nlHsTyApp, nlHsVar, nlHsLit, nlHsApp, nlHsApps, nlHsIntLit, nlHsVarApps, 

@@ -159,8 +159,11 @@ mkHsLam pats body = mkHsPar (L (getLoc body) (HsLam matches))
 mkMatchGroup :: [LMatch id] -> MatchGroup id
 mkMatchGroup matches = MatchGroup matches placeHolderType
 
 mkMatchGroup :: [LMatch id] -> MatchGroup id
 mkMatchGroup matches = MatchGroup matches placeHolderType
 

+mkHsLams :: [TyVar] -> [EvVar] -> LHsExpr Id -> LHsExpr Id
+mkHsLams tyvars dicts expr = mkLHsWrap (mkWpTyLams tyvars <.> mkWpLams dicts) expr
+

 mkHsDictLet :: TcEvBinds -> LHsExpr Id -> LHsExpr Id
 mkHsDictLet :: TcEvBinds -> LHsExpr Id -> LHsExpr Id

-mkHsDictLet ev_binds expr = mkLHsWrap (WpLet ev_binds) expr
+mkHsDictLet ev_binds expr = mkLHsWrap (mkWpLet ev_binds) expr

 
 mkHsConApp :: DataCon -> [Type] -> [HsExpr Id] -> LHsExpr Id
 -- Used for constructing dictionary terms etc, so no locations 
 
 mkHsConApp :: DataCon -> [Type] -> [HsExpr Id] -> LHsExpr Id
 -- Used for constructing dictionary terms etc, so no locations 

diff --git a/compiler/main/DynFlags.hs b/compiler/main/DynFlags.hs
index 1317441..494cc44 100644 (file)
--- a/compiler/main/DynFlags.hs
+++ b/compiler/main/DynFlags.hs
@@ -32,7 +32,7 @@ module DynFlags (
         Option(..), showOpt,
         DynLibLoader(..),
         fFlags, fLangFlags, xFlags,
         Option(..), showOpt,
         DynLibLoader(..),
         fFlags, fLangFlags, xFlags,

-        DPHBackend(..), dphPackage,
+        DPHBackend(..), dphPackageMaybe,

         wayNames,
 
         -- ** Manipulating DynFlags
         wayNames,
 
         -- ** Manipulating DynFlags

@@ -101,6 +101,7 @@ import Data.Char
 import Data.List
 import Data.Map (Map)
 import qualified Data.Map as Map
 import Data.List
 import Data.Map (Map)
 import qualified Data.Map as Map

+import Data.Maybe

 import System.FilePath
 import System.IO        ( stderr, hPutChar )
 
 import System.FilePath
 import System.IO        ( stderr, hPutChar )
 

@@ -156,6 +157,7 @@ data DynFlag
    | Opt_D_dump_cs_trace       -- Constraint solver in type checker
    | Opt_D_dump_tc_trace
    | Opt_D_dump_if_trace
    | Opt_D_dump_cs_trace       -- Constraint solver in type checker
    | Opt_D_dump_tc_trace
    | Opt_D_dump_if_trace

+   | Opt_D_dump_vt_trace

    | Opt_D_dump_splices
    | Opt_D_dump_BCOs
    | Opt_D_dump_vect
    | Opt_D_dump_splices
    | Opt_D_dump_BCOs
    | Opt_D_dump_vect

@@ -1262,6 +1264,7 @@ dynamic_flags = [
   , Flag "ddump-if-trace"          (setDumpFlag Opt_D_dump_if_trace)
   , Flag "ddump-cs-trace"          (setDumpFlag Opt_D_dump_cs_trace)
   , Flag "ddump-tc-trace"          (setDumpFlag Opt_D_dump_tc_trace)
   , Flag "ddump-if-trace"          (setDumpFlag Opt_D_dump_if_trace)
   , Flag "ddump-cs-trace"          (setDumpFlag Opt_D_dump_cs_trace)
   , Flag "ddump-tc-trace"          (setDumpFlag Opt_D_dump_tc_trace)

+  , Flag "ddump-vt-trace"          (setDumpFlag Opt_D_dump_vt_trace)

   , Flag "ddump-splices"           (setDumpFlag Opt_D_dump_splices)
   , Flag "ddump-rn-stats"          (setDumpFlag Opt_D_dump_rn_stats)
   , Flag "ddump-opt-cmm"           (setDumpFlag Opt_D_dump_opt_cmm)
   , Flag "ddump-splices"           (setDumpFlag Opt_D_dump_splices)
   , Flag "ddump-rn-stats"          (setDumpFlag Opt_D_dump_rn_stats)
   , Flag "ddump-opt-cmm"           (setDumpFlag Opt_D_dump_opt_cmm)

@@ -2014,18 +2017,15 @@ data DPHBackend = DPHPar    -- "dph-par"
 setDPHBackend :: DPHBackend -> DynP ()
 setDPHBackend backend = upd $ \dflags -> dflags { dphBackend = backend }
 
 setDPHBackend :: DPHBackend -> DynP ()
 setDPHBackend backend = upd $ \dflags -> dflags { dphBackend = backend }
 

--- Query the DPH backend package to be used by the vectoriser.
+-- Query the DPH backend package to be used by the vectoriser and desugaring of DPH syntax.

 --
 --

-dphPackage :: DynFlags -> PackageId
-dphPackage dflags 
+dphPackageMaybe :: DynFlags -> Maybe PackageId
+dphPackageMaybe dflags 

   = case dphBackend dflags of
   = case dphBackend dflags of

-      DPHPar  -> dphParPackageId
-      DPHSeq  -> dphSeqPackageId
-      DPHThis -> thisPackage dflags
-      DPHNone -> ghcError (CmdLineError dphBackendError)
-
-dphBackendError :: String
-dphBackendError = "To use -fvectorise select a DPH backend with -fdph-par or -fdph-seq"
+      DPHPar  -> Just dphParPackageId
+      DPHSeq  -> Just dphSeqPackageId
+      DPHThis -> Just (thisPackage dflags)
+      DPHNone -> Nothing

 
 setMainIs :: String -> DynP ()
 setMainIs arg
 
 setMainIs :: String -> DynP ()
 setMainIs arg

diff --git a/compiler/main/HscMain.lhs b/compiler/main/HscMain.lhs
index 312772e..582b80d 100644 (file)
--- a/compiler/main/HscMain.lhs
+++ b/compiler/main/HscMain.lhs
@@ -161,9 +161,9 @@ import Data.IORef
 newHscEnv :: DynFlags -> IO HscEnv
 newHscEnv dflags
   = do         { eps_var <- newIORef initExternalPackageState
 newHscEnv :: DynFlags -> IO HscEnv
 newHscEnv dflags
   = do         { eps_var <- newIORef initExternalPackageState

-       ; us      <- mkSplitUniqSupply 'r'
-       ; nc_var  <- newIORef (initNameCache us knownKeyNames)
-       ; fc_var  <- newIORef emptyUFM
+        ; us      <- mkSplitUniqSupply 'r'
+        ; nc_var  <- newIORef (initNameCache us knownKeyNames)
+        ; fc_var  <- newIORef emptyUFM

        ; mlc_var <- newIORef emptyModuleEnv
         ; optFuel <- initOptFuelState
        ; return (HscEnv { hsc_dflags = dflags,
        ; mlc_var <- newIORef emptyModuleEnv
         ; optFuel <- initOptFuelState
        ; return (HscEnv { hsc_dflags = dflags,

@@ -179,12 +179,13 @@ newHscEnv dflags
                            hsc_type_env_var = Nothing } ) }
 
 
                            hsc_type_env_var = Nothing } ) }
 
 

-knownKeyNames :: [Name]        -- Put here to avoid loops involving DsMeta,
-                       -- where templateHaskellNames are defined
-knownKeyNames = map getName wiredInThings 
-             ++ basicKnownKeyNames
+knownKeyNames :: [Name]      -- Put here to avoid loops involving DsMeta,
+                             -- where templateHaskellNames are defined
+knownKeyNames
+  = map getName wiredInThings 
+    ++ basicKnownKeyNames

 #ifdef GHCI
 #ifdef GHCI

-             ++ templateHaskellNames
+    ++ templateHaskellNames

 #endif
 
 -- -----------------------------------------------------------------------------
 #endif
 
 -- -----------------------------------------------------------------------------

@@ -1207,6 +1208,7 @@ mkModGuts mod binds = ModGuts {
   mg_insts = [],
   mg_fam_insts = [],
   mg_rules = [],
   mg_insts = [],
   mg_fam_insts = [],
   mg_rules = [],

+  mg_vect_decls = [],

   mg_binds = binds,
   mg_foreign = NoStubs,
   mg_warns = NoWarnings,
   mg_binds = binds,
   mg_foreign = NoStubs,
   mg_warns = NoWarnings,

diff --git a/compiler/main/HscTypes.lhs b/compiler/main/HscTypes.lhs
index 5d53739..3673b3e 100644 (file)
--- a/compiler/main/HscTypes.lhs
+++ b/compiler/main/HscTypes.lhs
@@ -130,7 +130,7 @@ import DriverPhases ( HscSource(..), isHsBoot, hscSourceString, Phase )
 import BasicTypes      ( IPName, defaultFixity, WarningTxt(..) )
 import OptimizationFuel        ( OptFuelState )
 import IfaceSyn
 import BasicTypes      ( IPName, defaultFixity, WarningTxt(..) )
 import OptimizationFuel        ( OptFuelState )
 import IfaceSyn

-import CoreSyn         ( CoreRule )
+import CoreSyn         ( CoreRule, CoreVect )

 import Maybes          ( orElse, expectJust, catMaybes )
 import Outputable
 import BreakArray
 import Maybes          ( orElse, expectJust, catMaybes )
 import Outputable
 import BreakArray

@@ -738,9 +738,11 @@ data ModGuts
        mg_binds     :: ![CoreBind],     -- ^ Bindings for this module
        mg_foreign   :: !ForeignStubs,   -- ^ Foreign exports declared in this module
        mg_warns     :: !Warnings,       -- ^ Warnings declared in the module
        mg_binds     :: ![CoreBind],     -- ^ Bindings for this module
        mg_foreign   :: !ForeignStubs,   -- ^ Foreign exports declared in this module
        mg_warns     :: !Warnings,       -- ^ Warnings declared in the module

-       mg_anns      :: [Annotation],    -- ^ Annotations declared in this module
-       mg_hpc_info  :: !HpcInfo,        -- ^ Coverage tick boxes in the module
+        mg_anns      :: [Annotation],    -- ^ Annotations declared in this module
+        mg_hpc_info  :: !HpcInfo,        -- ^ Coverage tick boxes in the module

         mg_modBreaks :: !ModBreaks,      -- ^ Breakpoints for the module
         mg_modBreaks :: !ModBreaks,      -- ^ Breakpoints for the module

+        mg_vect_decls:: ![CoreVect],     -- ^ Vectorisation declarations in this module
+                                         --   (produced by desugarer & consumed by vectoriser)

         mg_vect_info :: !VectInfo,       -- ^ Pool of vectorised declarations in the module
 
        -- The next two fields are unusual, because they give instance
         mg_vect_info :: !VectInfo,       -- ^ Pool of vectorised declarations in the module
 
        -- The next two fields are unusual, because they give instance

diff --git a/compiler/parser/Lexer.x b/compiler/parser/Lexer.x
index 5e65356..5c41d72 100644 (file)
--- a/compiler/parser/Lexer.x
+++ b/compiler/parser/Lexer.x
@@ -485,6 +485,8 @@ data Token
   | IToptions_prag String
   | ITinclude_prag String
   | ITlanguage_prag
   | IToptions_prag String
   | ITinclude_prag String
   | ITlanguage_prag

+  | ITvect_prag
+  | ITvect_scalar_prag

 
   | ITdotdot                   -- reserved symbols
   | ITcolon
 
   | ITdotdot                   -- reserved symbols
   | ITcolon

@@ -2275,13 +2277,14 @@ oneWordPrags = Map.fromList([("rules", rulePrag),
                            ("generated", token ITgenerated_prag),
                            ("core", token ITcore_prag),
                            ("unpack", token ITunpack_prag),
                            ("generated", token ITgenerated_prag),
                            ("core", token ITcore_prag),
                            ("unpack", token ITunpack_prag),

-                           ("ann", token ITann_prag)])
+                           ("ann", token ITann_prag),
+                           ("vectorize", token ITvect_prag)])

 
 twoWordPrags = Map.fromList([("inline conlike", token (ITinline_prag Inline ConLike)),
                              ("notinline conlike", token (ITinline_prag NoInline ConLike)),
                              ("specialize inline", token (ITspec_inline_prag True)),
 
 twoWordPrags = Map.fromList([("inline conlike", token (ITinline_prag Inline ConLike)),
                              ("notinline conlike", token (ITinline_prag NoInline ConLike)),
                              ("specialize inline", token (ITspec_inline_prag True)),

-                             ("specialize notinline", token (ITspec_inline_prag False))])
-
+                             ("specialize notinline", token (ITspec_inline_prag False)),
+                             ("vectorize scalar", token ITvect_scalar_prag)])

 
 dispatch_pragmas :: Map String Action -> Action
 dispatch_pragmas prags span buf len = case Map.lookup (clean_pragma (lexemeToString buf len)) prags of
 
 dispatch_pragmas :: Map String Action -> Action
 dispatch_pragmas prags span buf len = case Map.lookup (clean_pragma (lexemeToString buf len)) prags of

@@ -2300,6 +2303,7 @@ clean_pragma prag = canon_ws (map toLower (unprefix prag))
                           canonical prag' = case prag' of
                                               "noinline" -> "notinline"
                                               "specialise" -> "specialize"
                           canonical prag' = case prag' of
                                               "noinline" -> "notinline"
                                               "specialise" -> "specialize"

+                                              "vectorise" -> "vectorize"

                                               "constructorlike" -> "conlike"
                                               _ -> prag'
                           canon_ws s = unwords (map canonical (words s))
                                               "constructorlike" -> "conlike"
                                               _ -> prag'
                           canon_ws s = unwords (map canonical (words s))

diff --git a/compiler/parser/Parser.y.pp b/compiler/parser/Parser.y.pp
index a0cc964..bfadfba 100644 (file)
--- a/compiler/parser/Parser.y.pp
+++ b/compiler/parser/Parser.y.pp
@@ -266,6 +266,8 @@ incorrect.
  '{-# WARNING'     { L _ ITwarning_prag }
  '{-# UNPACK'      { L _ ITunpack_prag }
  '{-# ANN'         { L _ ITann_prag }
  '{-# WARNING'     { L _ ITwarning_prag }
  '{-# UNPACK'      { L _ ITunpack_prag }
  '{-# ANN'         { L _ ITann_prag }

+ '{-# VECTORISE'          { L _ ITvect_prag }
+ '{-# VECTORISE_SCALAR'   { L _ ITvect_scalar_prag }

  '#-}'            { L _ ITclose_prag }
 
  '..'          { L _ ITdotdot }                        -- reserved symbols
  '#-}'            { L _ ITclose_prag }
 
  '..'          { L _ ITdotdot }                        -- reserved symbols

@@ -563,6 +565,8 @@ topdecl :: { OrdList (LHsDecl RdrName) }
         | '{-# DEPRECATED' deprecations '#-}'   { $2 }
         | '{-# WARNING' warnings '#-}'          { $2 }
        | '{-# RULES' rules '#-}'               { $2 }
         | '{-# DEPRECATED' deprecations '#-}'   { $2 }
         | '{-# WARNING' warnings '#-}'          { $2 }
        | '{-# RULES' rules '#-}'               { $2 }

+       | '{-# VECTORISE_SCALAR' qvar '#-}'     { unitOL $ LL $ VectD (HsVect $2 Nothing) }
+       | '{-# VECTORISE' qvar '=' exp '#-}'    { unitOL $ LL $ VectD (HsVect $2 (Just $4)) }

        | annotation { unitOL $1 }
        | decl                                  { unLoc $1 }
 
        | annotation { unitOL $1 }
        | decl                                  { unLoc $1 }
 

diff --git a/compiler/prelude/PrelInfo.lhs b/compiler/prelude/PrelInfo.lhs
index 48981b3..867e79d 100644 (file)
--- a/compiler/prelude/PrelInfo.lhs
+++ b/compiler/prelude/PrelInfo.lhs
@@ -8,23 +8,23 @@ module PrelInfo (
         wiredInIds, ghcPrimIds,
         primOpRules, builtinRules,
 
         wiredInIds, ghcPrimIds,
         primOpRules, builtinRules,
 

-       ghcPrimExports,
-       wiredInThings, basicKnownKeyNames,
-       primOpId,
-       
-       -- Random other things
-       maybeCharLikeCon, maybeIntLikeCon,
+        ghcPrimExports,
+        wiredInThings, basicKnownKeyNames,
+        primOpId,
+        
+        -- Random other things
+        maybeCharLikeCon, maybeIntLikeCon,

 
 

-       -- Class categories
-       isNumericClass, isStandardClass
+        -- Class categories
+        isNumericClass, isStandardClass

 
     ) where
 
 #include "HsVersions.h"
 
 
     ) where
 
 #include "HsVersions.h"
 

-import PrelNames       ( basicKnownKeyNames, 
-                         hasKey, charDataConKey, intDataConKey,
-                         numericClassKeys, standardClassKeys )
+import PrelNames        ( basicKnownKeyNames,
+                          hasKey, charDataConKey, intDataConKey,
+                          numericClassKeys, standardClassKeys )

 import PrelRules
 import PrimOp          ( PrimOp, allThePrimOps, primOpOcc, primOpTag, maxPrimOpTag )
 import DataCon         ( DataCon )
 import PrelRules
 import PrimOp          ( PrimOp, allThePrimOps, primOpOcc, primOpTag, maxPrimOpTag )
 import DataCon         ( DataCon )

diff --git a/compiler/prelude/PrelNames.lhs b/compiler/prelude/PrelNames.lhs
index 4d3c446..f92d94e 100644 (file)
--- a/compiler/prelude/PrelNames.lhs
+++ b/compiler/prelude/PrelNames.lhs
@@ -89,20 +89,27 @@ isUnboundName name = name `hasKey` unboundKey
 
 
 %************************************************************************
 
 
 %************************************************************************

-%*                                                                     *
+%*                                                                      *

 \subsection{Known key Names}
 \subsection{Known key Names}

-%*                                                                     *
+%*                                                                      *

 %************************************************************************
 
 This section tells what the compiler knows about the assocation of
 names with uniques.  These ones are the *non* wired-in ones.  The
 wired in ones are defined in TysWiredIn etc.
 
 %************************************************************************
 
 This section tells what the compiler knows about the assocation of
 names with uniques.  These ones are the *non* wired-in ones.  The
 wired in ones are defined in TysWiredIn etc.
 

+The names for DPH can come from one of multiple backend packages. At the point where 
+'basicKnownKeyNames' is used, we don't know which backend it will be.  Hence, we list
+the names for multiple backends.  That works out fine, although they use the same uniques,
+as we are guaranteed to only load one backend; hence, only one of the different names
+sharing a unique will be used.
+

 \begin{code}
 basicKnownKeyNames :: [Name]
 basicKnownKeyNames
  = genericTyConNames
  ++ typeableClassNames
 \begin{code}
 basicKnownKeyNames :: [Name]
 basicKnownKeyNames
  = genericTyConNames
  ++ typeableClassNames

+ ++ dphKnownKeyNames dphSeqPackageId ++ dphKnownKeyNames dphParPackageId

  ++ [  -- Type constructors (synonyms especially)
        ioTyConName, ioDataConName,
        runMainIOName,
  ++ [  -- Type constructors (synonyms especially)
        ioTyConName, ioDataConName,
        runMainIOName,

@@ -149,7 +156,6 @@ basicKnownKeyNames
        -- Enum stuff
        enumFromName, enumFromThenName, 
        enumFromThenToName, enumFromToName,
        -- Enum stuff
        enumFromName, enumFromThenName, 
        enumFromThenToName, enumFromToName,

-       enumFromToPName, enumFromThenToPName,

 
        -- Monad stuff
        thenIOName, bindIOName, returnIOName, failIOName,
 
        -- Monad stuff
        thenIOName, bindIOName, returnIOName, failIOName,

@@ -187,11 +193,6 @@ basicKnownKeyNames
 
         dollarName,        -- The ($) apply function
 
 
         dollarName,        -- The ($) apply function
 

-        -- Parallel array operations
-       nullPName, lengthPName, replicatePName, singletonPName, mapPName,
-       filterPName, zipPName, crossMapPName, indexPName,
-       toPName, emptyPName, appPName,
-

        -- FFI primitive types that are not wired-in.
        stablePtrTyConName, ptrTyConName, funPtrTyConName,
        int8TyConName, int16TyConName, int32TyConName, int64TyConName,
        -- FFI primitive types that are not wired-in.
        stablePtrTyConName, ptrTyConName, funPtrTyConName,
        int8TyConName, int16TyConName, int32TyConName, int64TyConName,

@@ -224,6 +225,20 @@ basicKnownKeyNames
 
 genericTyConNames :: [Name]
 genericTyConNames = [crossTyConName, plusTyConName, genUnitTyConName]
 
 genericTyConNames :: [Name]
 genericTyConNames = [crossTyConName, plusTyConName, genUnitTyConName]

+
+-- Know names from the DPH package which vary depending on the selected DPH backend.
+--
+dphKnownKeyNames :: PackageId -> [Name]
+dphKnownKeyNames dphPkg
+  = map ($ dphPkg)
+    [
+        -- Parallel array operations
+         nullPName, lengthPName, replicatePName,       singletonPName, mapPName,
+         filterPName, zipPName, crossMapPName, indexPName,
+         toPName, emptyPName, appPName,
+       enumFromToPName, enumFromThenToPName
+
+    ]

 \end{code}
 
 
 \end{code}
 
 

@@ -242,7 +257,7 @@ pRELUDE             = mkBaseModule_ pRELUDE_NAME
 gHC_PRIM, gHC_TYPES, gHC_UNIT, gHC_ORDERING, gHC_GENERICS,
     gHC_MAGIC,
     gHC_CLASSES, gHC_BASE, gHC_ENUM,
 gHC_PRIM, gHC_TYPES, gHC_UNIT, gHC_ORDERING, gHC_GENERICS,
     gHC_MAGIC,
     gHC_CLASSES, gHC_BASE, gHC_ENUM,

-    gHC_SHOW, gHC_READ, gHC_NUM, gHC_INTEGER, gHC_INTEGER_TYPE, gHC_LIST, gHC_PARR,
+    gHC_SHOW, gHC_READ, gHC_NUM, gHC_INTEGER, gHC_INTEGER_TYPE, gHC_LIST,

     gHC_TUPLE, dATA_TUPLE, dATA_EITHER, dATA_STRING, dATA_FOLDABLE, dATA_TRAVERSABLE,
     gHC_PACK, gHC_CONC, gHC_IO, gHC_IO_Exception,
     gHC_ST, gHC_ARR, gHC_STABLE, gHC_ADDR, gHC_PTR, gHC_ERR, gHC_REAL,
     gHC_TUPLE, dATA_TUPLE, dATA_EITHER, dATA_STRING, dATA_FOLDABLE, dATA_TRAVERSABLE,
     gHC_PACK, gHC_CONC, gHC_IO, gHC_IO_Exception,
     gHC_ST, gHC_ARR, gHC_STABLE, gHC_ADDR, gHC_PTR, gHC_ERR, gHC_REAL,

@@ -265,10 +280,9 @@ gHC_READ   = mkBaseModule (fsLit "GHC.Read")
 gHC_NUM                = mkBaseModule (fsLit "GHC.Num")
 gHC_INTEGER    = mkIntegerModule (fsLit "GHC.Integer")
 gHC_INTEGER_TYPE= mkIntegerModule (fsLit "GHC.Integer.Type")
 gHC_NUM                = mkBaseModule (fsLit "GHC.Num")
 gHC_INTEGER    = mkIntegerModule (fsLit "GHC.Integer")
 gHC_INTEGER_TYPE= mkIntegerModule (fsLit "GHC.Integer.Type")

-gHC_LIST       = mkBaseModule (fsLit "GHC.List")
-gHC_PARR       = mkBaseModule (fsLit "GHC.PArr")
-gHC_TUPLE      = mkPrimModule (fsLit "GHC.Tuple")
-dATA_TUPLE     = mkBaseModule (fsLit "Data.Tuple")
+gHC_LIST        = mkBaseModule (fsLit "GHC.List")
+gHC_TUPLE       = mkPrimModule (fsLit "GHC.Tuple")
+dATA_TUPLE      = mkBaseModule (fsLit "Data.Tuple")

 dATA_EITHER    = mkBaseModule (fsLit "Data.Either")
 dATA_STRING    = mkBaseModule (fsLit "Data.String")
 dATA_FOLDABLE  = mkBaseModule (fsLit "Data.Foldable")
 dATA_EITHER    = mkBaseModule (fsLit "Data.Either")
 dATA_STRING    = mkBaseModule (fsLit "Data.String")
 dATA_FOLDABLE  = mkBaseModule (fsLit "Data.Foldable")

@@ -304,6 +318,12 @@ rANDOM             = mkBaseModule (fsLit "System.Random")
 gHC_EXTS       = mkBaseModule (fsLit "GHC.Exts")
 cONTROL_EXCEPTION_BASE = mkBaseModule (fsLit "Control.Exception.Base")
 
 gHC_EXTS       = mkBaseModule (fsLit "GHC.Exts")
 cONTROL_EXCEPTION_BASE = mkBaseModule (fsLit "Control.Exception.Base")
 

+gHC_PARR :: PackageId -> Module
+gHC_PARR pkg = mkModule pkg (mkModuleNameFS (fsLit "Data.Array.Parallel"))
+
+gHC_PARR' :: Module
+gHC_PARR' = mkBaseModule (fsLit "GHC.PArr")
+

 mAIN, rOOT_MAIN :: Module
 mAIN           = mkMainModule_ mAIN_NAME
 rOOT_MAIN      = mkMainModule (fsLit ":Main") -- Root module for initialisation 
 mAIN, rOOT_MAIN :: Module
 mAIN           = mkMainModule_ mAIN_NAME
 rOOT_MAIN      = mkMainModule (fsLit ":Main") -- Root module for initialisation 

@@ -739,21 +759,21 @@ readClassName        = clsQual gHC_READ (fsLit "Read") readClassKey
 enumFromToPName, enumFromThenToPName, nullPName, lengthPName,
     singletonPName, replicatePName, mapPName, filterPName,
     zipPName, crossMapPName, indexPName, toPName,
 enumFromToPName, enumFromThenToPName, nullPName, lengthPName,
     singletonPName, replicatePName, mapPName, filterPName,
     zipPName, crossMapPName, indexPName, toPName,

-    emptyPName, appPName :: Name
-enumFromToPName           = varQual gHC_PARR (fsLit "enumFromToP") enumFromToPIdKey
-enumFromThenToPName= varQual gHC_PARR (fsLit "enumFromThenToP") enumFromThenToPIdKey
-nullPName        = varQual gHC_PARR (fsLit "nullP")             nullPIdKey
-lengthPName      = varQual gHC_PARR (fsLit "lengthP")           lengthPIdKey
-singletonPName    = varQual gHC_PARR (fsLit "singletonP")         singletonPIdKey
-replicatePName   = varQual gHC_PARR (fsLit "replicateP")        replicatePIdKey
-mapPName         = varQual gHC_PARR (fsLit "mapP")              mapPIdKey
-filterPName      = varQual gHC_PARR (fsLit "filterP")           filterPIdKey
-zipPName         = varQual gHC_PARR (fsLit "zipP")              zipPIdKey
-crossMapPName    = varQual gHC_PARR (fsLit "crossMapP")         crossMapPIdKey
-indexPName       = varQual gHC_PARR (fsLit "!:")                indexPIdKey
-toPName                  = varQual gHC_PARR (fsLit "toP")               toPIdKey
-emptyPName        = varQual gHC_PARR (fsLit "emptyP")            emptyPIdKey
-appPName          = varQual gHC_PARR (fsLit "+:+")               appPIdKey
+    emptyPName, appPName :: PackageId -> Name
+enumFromToPName     pkg = varQual (gHC_PARR pkg) (fsLit "enumFromToP")     enumFromToPIdKey
+enumFromThenToPName pkg = varQual (gHC_PARR pkg) (fsLit "enumFromThenToP") enumFromThenToPIdKey
+nullPName           pkg = varQual (gHC_PARR pkg) (fsLit "nullP")           nullPIdKey
+lengthPName         pkg = varQual (gHC_PARR pkg) (fsLit "lengthP")         lengthPIdKey
+singletonPName      pkg = varQual (gHC_PARR pkg) (fsLit "singletonP")      singletonPIdKey
+replicatePName      pkg = varQual (gHC_PARR pkg) (fsLit "replicateP")      replicatePIdKey
+mapPName            pkg = varQual (gHC_PARR pkg) (fsLit "mapP")            mapPIdKey
+filterPName         pkg = varQual (gHC_PARR pkg) (fsLit "filterP")         filterPIdKey
+zipPName            pkg = varQual (gHC_PARR pkg) (fsLit "zipP")            zipPIdKey
+crossMapPName       pkg = varQual (gHC_PARR pkg) (fsLit "crossMapP")       crossMapPIdKey
+indexPName          pkg = varQual (gHC_PARR pkg) (fsLit "!:")              indexPIdKey
+toPName             pkg = varQual (gHC_PARR pkg) (fsLit "toP")             toPIdKey
+emptyPName          pkg = varQual (gHC_PARR pkg) (fsLit "emptyP")          emptyPIdKey
+appPName            pkg = varQual (gHC_PARR pkg) (fsLit "+:+")             appPIdKey

 
 -- IO things
 ioTyConName, ioDataConName, thenIOName, bindIOName, returnIOName,
 
 -- IO things
 ioTyConName, ioDataConName, thenIOName, bindIOName, returnIOName,

diff --git a/compiler/prelude/TysWiredIn.lhs b/compiler/prelude/TysWiredIn.lhs
index f77b272..db2ea1b 100644 (file)
--- a/compiler/prelude/TysWiredIn.lhs
+++ b/compiler/prelude/TysWiredIn.lhs
@@ -169,8 +169,10 @@ doubleTyConName    = mkWiredInTyConName   UserSyntax gHC_TYPES (fsLit "Double")
 doubleDataConName  = mkWiredInDataConName UserSyntax gHC_TYPES (fsLit "D#") doubleDataConKey doubleDataCon
 
 parrTyConName, parrDataConName :: Name
 doubleDataConName  = mkWiredInDataConName UserSyntax gHC_TYPES (fsLit "D#") doubleDataConKey doubleDataCon
 
 parrTyConName, parrDataConName :: Name

-parrTyConName    = mkWiredInTyConName   BuiltInSyntax gHC_PARR (fsLit "[::]") parrTyConKey parrTyCon 
-parrDataConName   = mkWiredInDataConName UserSyntax    gHC_PARR (fsLit "PArr") parrDataConKey parrDataCon
+parrTyConName   = mkWiredInTyConName   BuiltInSyntax 
+                    gHC_PARR' (fsLit "[::]") parrTyConKey parrTyCon 
+parrDataConName = mkWiredInDataConName UserSyntax    
+                    gHC_PARR' (fsLit "PArr") parrDataConKey parrDataCon

 
 boolTyCon_RDR, false_RDR, true_RDR, intTyCon_RDR, charTyCon_RDR,
     intDataCon_RDR, listTyCon_RDR, consDataCon_RDR, parrTyCon_RDR:: RdrName
 
 boolTyCon_RDR, false_RDR, true_RDR, intTyCon_RDR, charTyCon_RDR,
     intDataCon_RDR, listTyCon_RDR, consDataCon_RDR, parrTyCon_RDR:: RdrName

@@ -600,7 +602,7 @@ mkPArrFakeCon arity  = data_con
        tyvar     = head alphaTyVars
        tyvarTys  = replicate arity $ mkTyVarTy tyvar
         nameStr   = mkFastString ("MkPArr" ++ show arity)
        tyvar     = head alphaTyVars
        tyvarTys  = replicate arity $ mkTyVarTy tyvar
         nameStr   = mkFastString ("MkPArr" ++ show arity)

-       name      = mkWiredInName gHC_PARR (mkDataOccFS nameStr) unique
+       name      = mkWiredInName gHC_PARR' (mkDataOccFS nameStr) unique

                                  (ADataCon data_con) UserSyntax
        unique      = mkPArrDataConUnique arity
 
                                  (ADataCon data_con) UserSyntax
        unique      = mkPArrDataConUnique arity
 

diff --git a/compiler/rename/RnSource.lhs b/compiler/rename/RnSource.lhs
index 2ce2170..725baeb 100644 (file)
--- a/compiler/rename/RnSource.lhs
+++ b/compiler/rename/RnSource.lhs
@@ -97,6 +97,7 @@ rnSrcDecls group@(HsGroup { hs_valds   = val_decls,
                             hs_fords   = foreign_decls,
                             hs_defds   = default_decls,
                             hs_ruleds  = rule_decls,
                             hs_fords   = foreign_decls,
                             hs_defds   = default_decls,
                             hs_ruleds  = rule_decls,

+                            hs_vects   = vect_decls,

                             hs_docs    = docs })
  = do {
    -- (A) Process the fixity declarations, creating a mapping from
                             hs_docs    = docs })
  = do {
    -- (A) Process the fixity declarations, creating a mapping from

@@ -169,12 +170,13 @@ rnSrcDecls group@(HsGroup { hs_valds   = val_decls,
 
    (rn_inst_decls,    src_fvs2) <- rnList rnSrcInstDecl   inst_decls ;
    (rn_rule_decls,    src_fvs3) <- setOptM Opt_ScopedTypeVariables $
 
    (rn_inst_decls,    src_fvs2) <- rnList rnSrcInstDecl   inst_decls ;
    (rn_rule_decls,    src_fvs3) <- setOptM Opt_ScopedTypeVariables $

-                                  rnList rnHsRuleDecl    rule_decls ;
-                          -- Inside RULES, scoped type variables are on
-   (rn_foreign_decls, src_fvs4) <- rnList rnHsForeignDecl foreign_decls ;
-   (rn_ann_decls,     src_fvs5) <- rnList rnAnnDecl       ann_decls ;
-   (rn_default_decls, src_fvs6) <- rnList rnDefaultDecl   default_decls ;
-   (rn_deriv_decls,   src_fvs7) <- rnList rnSrcDerivDecl  deriv_decls ;
+                                   rnList rnHsRuleDecl    rule_decls ;
+                           -- Inside RULES, scoped type variables are on
+   (rn_vect_decls,    src_fvs4) <- rnList rnHsVectDecl    vect_decls ;
+   (rn_foreign_decls, src_fvs5) <- rnList rnHsForeignDecl foreign_decls ;
+   (rn_ann_decls,     src_fvs6) <- rnList rnAnnDecl       ann_decls ;
+   (rn_default_decls, src_fvs7) <- rnList rnDefaultDecl   default_decls ;
+   (rn_deriv_decls,   src_fvs8) <- rnList rnSrcDerivDecl  deriv_decls ;

       -- Haddock docs; no free vars
    rn_docs <- mapM (wrapLocM rnDocDecl) docs ;
 
       -- Haddock docs; no free vars
    rn_docs <- mapM (wrapLocM rnDocDecl) docs ;
 

@@ -190,13 +192,14 @@ rnSrcDecls group@(HsGroup { hs_valds   = val_decls,
                             hs_annds  = rn_ann_decls,
                             hs_defds  = rn_default_decls,
                             hs_ruleds = rn_rule_decls,
                             hs_annds  = rn_ann_decls,
                             hs_defds  = rn_default_decls,
                             hs_ruleds = rn_rule_decls,

+                            hs_vects  = rn_vect_decls,

                              hs_docs   = rn_docs } ;
 
         tycl_bndrs = hsTyClDeclsBinders rn_tycl_decls rn_inst_decls ;
         ford_bndrs = hsForeignDeclsBinders rn_foreign_decls ;
        other_def  = (Just (mkNameSet tycl_bndrs `unionNameSets` mkNameSet ford_bndrs), emptyNameSet) ;
         other_fvs  = plusFVs [src_fvs1, src_fvs2, src_fvs3, src_fvs4, 
                              hs_docs   = rn_docs } ;
 
         tycl_bndrs = hsTyClDeclsBinders rn_tycl_decls rn_inst_decls ;
         ford_bndrs = hsForeignDeclsBinders rn_foreign_decls ;
        other_def  = (Just (mkNameSet tycl_bndrs `unionNameSets` mkNameSet ford_bndrs), emptyNameSet) ;
         other_fvs  = plusFVs [src_fvs1, src_fvs2, src_fvs3, src_fvs4, 

-                             src_fvs5, src_fvs6, src_fvs7] ;
+                             src_fvs5, src_fvs6, src_fvs7, src_fvs8] ;

                -- It is tiresome to gather the binders from type and class decls
 
        src_dus = [other_def] `plusDU` bind_dus `plusDU` usesOnly other_fvs ;
                -- It is tiresome to gather the binders from type and class decls
 
        src_dus = [other_def] `plusDU` bind_dus `plusDU` usesOnly other_fvs ;

@@ -658,6 +661,25 @@ badRuleLhsErr name lhs bad_e
 
 
 %*********************************************************
 
 
 %*********************************************************

+%*                                                      *
+\subsection{Vectorisation declarations}
+%*                                                      *
+%*********************************************************
+
+\begin{code}
+rnHsVectDecl :: VectDecl RdrName -> RnM (VectDecl Name, FreeVars)
+rnHsVectDecl (HsVect var Nothing)
+  = do { var' <- wrapLocM lookupTopBndrRn var
+       ; return (HsVect var' Nothing, unitFV (unLoc var'))
+       }
+rnHsVectDecl (HsVect var (Just rhs))
+  = do { var' <- wrapLocM lookupTopBndrRn var
+       ; (rhs', fv_rhs) <- rnLExpr rhs
+       ; return (HsVect var' (Just rhs'), fv_rhs `addOneFV` unLoc var')
+       }
+\end{code}
+
+%*********************************************************

 %*                                                     *
 \subsection{Type, class and iface sig declarations}
 %*                                                     *
 %*                                                     *
 \subsection{Type, class and iface sig declarations}
 %*                                                     *

@@ -1214,6 +1236,8 @@ add gp@(HsGroup {hs_annds  = ts}) l (AnnD d) ds
   = addl (gp { hs_annds = L l d : ts }) ds
 add gp@(HsGroup {hs_ruleds  = ts}) l (RuleD d) ds
   = addl (gp { hs_ruleds = L l d : ts }) ds
   = addl (gp { hs_annds = L l d : ts }) ds
 add gp@(HsGroup {hs_ruleds  = ts}) l (RuleD d) ds
   = addl (gp { hs_ruleds = L l d : ts }) ds

+add gp@(HsGroup {hs_vects  = ts}) l (VectD d) ds
+  = addl (gp { hs_vects = L l d : ts }) ds

 add gp l (DocD d) ds
   = addl (gp { hs_docs = (L l d) : (hs_docs gp) })  ds
 
 add gp l (DocD d) ds
   = addl (gp { hs_docs = (L l d) : (hs_docs gp) })  ds
 

diff --git a/compiler/simplCore/CoreMonad.lhs b/compiler/simplCore/CoreMonad.lhs
index 0b8ea1e..bb598c6 100644 (file)
--- a/compiler/simplCore/CoreMonad.lhs
+++ b/compiler/simplCore/CoreMonad.lhs
@@ -58,7 +58,7 @@ import CoreUtils
 import CoreLint                ( lintCoreBindings )
 import PrelNames        ( iNTERACTIVE )
 import HscTypes
 import CoreLint                ( lintCoreBindings )
 import PrelNames        ( iNTERACTIVE )
 import HscTypes

-import Module           ( PackageId, Module )
+import Module           ( Module )

 import DynFlags
 import StaticFlags     
 import Rules            ( RuleBase )
 import DynFlags
 import StaticFlags     
 import Rules            ( RuleBase )

@@ -219,7 +219,7 @@ data CoreToDo           -- These are diff core-to-core passes,
   | CoreCSE
   | CoreDoRuleCheck CompilerPhase String   -- Check for non-application of rules
                                            -- matching this string
   | CoreCSE
   | CoreDoRuleCheck CompilerPhase String   -- Check for non-application of rules
                                            -- matching this string

-  | CoreDoVectorisation PackageId
+  | CoreDoVectorisation

   | CoreDoNothing                -- Useful when building up
   | CoreDoPasses [CoreToDo]      -- lists of these things
 
   | CoreDoNothing                -- Useful when building up
   | CoreDoPasses [CoreToDo]      -- lists of these things
 

@@ -240,10 +240,10 @@ coreDumpFlag CoreDoWorkerWrapper      = Just Opt_D_dump_worker_wrapper
 coreDumpFlag CoreDoSpecialising       = Just Opt_D_dump_spec
 coreDumpFlag CoreDoSpecConstr         = Just Opt_D_dump_spec
 coreDumpFlag CoreCSE                  = Just Opt_D_dump_cse 
 coreDumpFlag CoreDoSpecialising       = Just Opt_D_dump_spec
 coreDumpFlag CoreDoSpecConstr         = Just Opt_D_dump_spec
 coreDumpFlag CoreCSE                  = Just Opt_D_dump_cse 

-coreDumpFlag (CoreDoVectorisation {}) = Just Opt_D_dump_vect
-coreDumpFlag CoreDesugar             = Just Opt_D_dump_ds 
-coreDumpFlag CoreTidy                = Just Opt_D_dump_simpl
-coreDumpFlag CorePrep                = Just Opt_D_dump_prep
+coreDumpFlag CoreDoVectorisation      = Just Opt_D_dump_vect
+coreDumpFlag CoreDesugar              = Just Opt_D_dump_ds 
+coreDumpFlag CoreTidy                 = Just Opt_D_dump_simpl
+coreDumpFlag CorePrep                 = Just Opt_D_dump_prep

 
 coreDumpFlag CoreDoPrintCore         = Nothing
 coreDumpFlag (CoreDoRuleCheck {})    = Nothing
 
 coreDumpFlag CoreDoPrintCore         = Nothing
 coreDumpFlag (CoreDoRuleCheck {})    = Nothing

@@ -264,9 +264,9 @@ instance Outputable CoreToDo where
   ppr CoreDoSpecialising       = ptext (sLit "Specialise")
   ppr CoreDoSpecConstr         = ptext (sLit "SpecConstr")
   ppr CoreCSE                  = ptext (sLit "Common sub-expression")
   ppr CoreDoSpecialising       = ptext (sLit "Specialise")
   ppr CoreDoSpecConstr         = ptext (sLit "SpecConstr")
   ppr CoreCSE                  = ptext (sLit "Common sub-expression")

-  ppr (CoreDoVectorisation {}) = ptext (sLit "Vectorisation")
-  ppr CoreDesugar             = ptext (sLit "Desugar")
-  ppr CoreTidy                        = ptext (sLit "Tidy Core")
+  ppr CoreDoVectorisation      = ptext (sLit "Vectorisation")
+  ppr CoreDesugar              = ptext (sLit "Desugar")
+  ppr CoreTidy                 = ptext (sLit "Tidy Core")

   ppr CorePrep                        = ptext (sLit "CorePrep")
   ppr CoreDoPrintCore          = ptext (sLit "Print core")
   ppr (CoreDoRuleCheck {})     = ptext (sLit "Rule check")
   ppr CorePrep                        = ptext (sLit "CorePrep")
   ppr CoreDoPrintCore          = ptext (sLit "Print core")
   ppr (CoreDoRuleCheck {})     = ptext (sLit "Rule check")

@@ -379,9 +379,8 @@ getCoreToDo dflags
           ]
 
     vectorisation
           ]
 
     vectorisation

-      = runWhen (dopt Opt_Vectorise dflags)
-        $ CoreDoPasses [ simpl_gently, CoreDoVectorisation (dphPackage dflags) ]
-
+      = runWhen (dopt Opt_Vectorise dflags) $
+          CoreDoPasses [ simpl_gently, CoreDoVectorisation ]

 
                 -- By default, we have 2 phases before phase 0.
 
 
                 -- By default, we have 2 phases before phase 0.
 

diff --git a/compiler/simplCore/SimplCore.lhs b/compiler/simplCore/SimplCore.lhs
index b64de6e..1a634d5 100644 (file)
--- a/compiler/simplCore/SimplCore.lhs
+++ b/compiler/simplCore/SimplCore.lhs
@@ -123,8 +123,8 @@ doCorePass CoreDoSpecialising        = {-# SCC "Specialise" #-}
 doCorePass CoreDoSpecConstr          = {-# SCC "SpecConstr" #-}
                                        specConstrProgram
 
 doCorePass CoreDoSpecConstr          = {-# SCC "SpecConstr" #-}
                                        specConstrProgram
 

-doCorePass (CoreDoVectorisation be)  = {-# SCC "Vectorise" #-}
-                                       vectorise be
+doCorePass CoreDoVectorisation       = {-# SCC "Vectorise" #-}
+                                       vectorise

 
 doCorePass CoreDoGlomBinds              = doPassDM  glomBinds
 doCorePass CoreDoPrintCore              = observe   printCore
 
 doCorePass CoreDoGlomBinds              = doPassDM  glomBinds
 doCorePass CoreDoPrintCore              = observe   printCore

diff --git a/compiler/typecheck/TcBinds.lhs b/compiler/typecheck/TcBinds.lhs
index c9f2a2d..0da6cdb 100644 (file)
--- a/compiler/typecheck/TcBinds.lhs
+++ b/compiler/typecheck/TcBinds.lhs
@@ -7,7 +7,7 @@
 \begin{code}
 module TcBinds ( tcLocalBinds, tcTopBinds, 
                  tcHsBootSigs, tcPolyBinds,
 \begin{code}
 module TcBinds ( tcLocalBinds, tcTopBinds, 
                  tcHsBootSigs, tcPolyBinds,

-                 PragFun, tcSpecPrags, mkPragFun, 
+                 PragFun, tcSpecPrags, tcVectDecls, mkPragFun, 

                  TcSigInfo(..), SigFun, mkSigFun,
                  badBootDeclErr ) where
 
                  TcSigInfo(..), SigFun, mkSigFun,
                  badBootDeclErr ) where
 

@@ -35,6 +35,7 @@ import NameSet
 import NameEnv
 import SrcLoc
 import Bag
 import NameEnv
 import SrcLoc
 import Bag

+import ListSetOps

 import ErrUtils
 import Digraph
 import Maybes
 import ErrUtils
 import Digraph
 import Maybes

@@ -577,7 +578,65 @@ impSpecErr :: Name -> SDoc
 impSpecErr name
   = hang (ptext (sLit "You cannot SPECIALISE") <+> quotes (ppr name))
        2 (vcat [ ptext (sLit "because its definition has no INLINE/INLINABLE pragma")
 impSpecErr name
   = hang (ptext (sLit "You cannot SPECIALISE") <+> quotes (ppr name))
        2 (vcat [ ptext (sLit "because its definition has no INLINE/INLINABLE pragma")

-               , ptext (sLit "(or you compiled its definining module without -O)")])
+               , ptext (sLit "(or you compiled its defining module without -O)")])
+
+--------------
+tcVectDecls :: [LVectDecl Name] -> TcM [LVectDecl TcId]
+tcVectDecls decls 
+  = do { decls' <- mapM (wrapLocM tcVect) decls
+       ; let ids  = [unLoc id | L _ (HsVect id _) <- decls']
+             dups = findDupsEq (==) ids
+       ; mapM_ reportVectDups dups
+       ; return decls'
+       }
+  where
+    reportVectDups (first:_second:_more) 
+      = addErrAt (getSrcSpan first) $
+          ptext (sLit "Duplicate vectorisation declarations for") <+> ppr first
+    reportVectDups _ = return ()
+
+--------------
+tcVect :: VectDecl Name -> TcM (VectDecl TcId)
+-- We can't typecheck the expression of a vectorisation declaration against the vectorised type
+-- of the original definition as this requires internals of the vectoriser not available during
+-- type checking.  Instead, we infer the type of the expression and leave it to the vectoriser
+-- to check the compatibility of the Core types.
+tcVect (HsVect name Nothing)
+  = addErrCtxt (vectCtxt name) $
+    do { id <- wrapLocM tcLookupId name
+       ; return (HsVect id Nothing)
+       }
+tcVect (HsVect name@(L loc _) (Just rhs))
+  = addErrCtxt (vectCtxt name) $
+    do { _id <- wrapLocM tcLookupId name     -- need to ensure that the name is already defined
+
+         -- turn the vectorisation declaration into a single non-recursive binding
+       ; let bind    = L loc $ mkFunBind name [mkSimpleMatch [] rhs] 
+             sigFun  = const Nothing
+             pragFun = mkPragFun [] (unitBag bind)
+
+         -- perform type inference (including generalisation)
+       ; (binds, [id']) <- tcPolyInfer TopLevel False sigFun pragFun NonRecursive [bind]
+
+       ; traceTc "tcVect inferred type" $ ppr (varType id')
+       
+         -- add the type variable and dictionary bindings produced by type generalisation to the
+         -- right-hand side of the vectorisation declaration
+       ; let [AbsBinds tvs evs _ evBinds actualBinds] = (map unLoc . bagToList) binds
+       ; let [bind']                                  = bagToList actualBinds
+             MatchGroup 
+               [L _ (Match _ _ (GRHSs [L _ (GRHS _ rhs')] _))]
+               _                                      = (fun_matches . unLoc) bind'
+             rhsWrapped                               = mkHsLams tvs evs (mkHsDictLet evBinds rhs')
+        
+        -- We return the type-checked 'Id', to propagate the inferred signature
+        -- to the vectoriser - see "Note [Typechecked vectorisation pragmas]" in HsDecls
+       ; return $ HsVect (L loc id') (Just rhsWrapped)
+       }
+
+vectCtxt :: Located Name -> SDoc
+vectCtxt name = ptext (sLit "When checking the vectorisation declaration for") <+> ppr name
+

 --------------
 -- If typechecking the binds fails, then return with each
 -- signature-less binder given type (forall a.a), to minimise 
 --------------
 -- If typechecking the binds fails, then return with each
 -- signature-less binder given type (forall a.a), to minimise 

diff --git a/compiler/typecheck/TcExpr.lhs b/compiler/typecheck/TcExpr.lhs
index 3f5a258..6bb0820 100644 (file)
--- a/compiler/typecheck/TcExpr.lhs
+++ b/compiler/typecheck/TcExpr.lhs
@@ -49,6 +49,7 @@ import TysWiredIn
 import TysPrim( intPrimTy )
 import PrimOp( tagToEnumKey )
 import PrelNames
 import TysPrim( intPrimTy )
 import PrimOp( tagToEnumKey )
 import PrelNames

+import Module

 import DynFlags
 import SrcLoc
 import Util
 import DynFlags
 import SrcLoc
 import Util

@@ -737,7 +738,7 @@ tcExpr (PArrSeq _ seq@(FromTo expr1 expr2)) res_ty
        ; expr1' <- tcPolyExpr expr1 elt_ty
        ; expr2' <- tcPolyExpr expr2 elt_ty
        ; enum_from_to <- newMethodFromName (PArrSeqOrigin seq) 
        ; expr1' <- tcPolyExpr expr1 elt_ty
        ; expr2' <- tcPolyExpr expr2 elt_ty
        ; enum_from_to <- newMethodFromName (PArrSeqOrigin seq) 

-                                enumFromToPName elt_ty 
+                                (enumFromToPName basePackageId) elt_ty    -- !!!FIXME: chak

        ; return $ mkHsWrapCoI coi 
                      (PArrSeq enum_from_to (FromTo expr1' expr2')) }
 
        ; return $ mkHsWrapCoI coi 
                      (PArrSeq enum_from_to (FromTo expr1' expr2')) }
 

@@ -747,7 +748,7 @@ tcExpr (PArrSeq _ seq@(FromThenTo expr1 expr2 expr3)) res_ty
        ; expr2' <- tcPolyExpr expr2 elt_ty
        ; expr3' <- tcPolyExpr expr3 elt_ty
        ; eft <- newMethodFromName (PArrSeqOrigin seq)
        ; expr2' <- tcPolyExpr expr2 elt_ty
        ; expr3' <- tcPolyExpr expr3 elt_ty
        ; eft <- newMethodFromName (PArrSeqOrigin seq)

-                     enumFromThenToPName elt_ty
+                     (enumFromThenToPName basePackageId) elt_ty        -- !!!FIXME: chak

        ; return $ mkHsWrapCoI coi 
                      (PArrSeq eft (FromThenTo expr1' expr2' expr3')) }
 
        ; return $ mkHsWrapCoI coi 
                      (PArrSeq eft (FromThenTo expr1' expr2' expr3')) }
 

diff --git a/compiler/typecheck/TcHsSyn.lhs b/compiler/typecheck/TcHsSyn.lhs
index b7b572f..122b743 100644 (file)
--- a/compiler/typecheck/TcHsSyn.lhs
+++ b/compiler/typecheck/TcHsSyn.lhs
@@ -269,15 +269,16 @@ zonkTopLExpr e = zonkLExpr emptyZonkEnv e
 
 zonkTopDecls :: Bag EvBind 
              -> LHsBinds TcId -> NameSet
 
 zonkTopDecls :: Bag EvBind 
              -> LHsBinds TcId -> NameSet

-             -> [LRuleDecl TcId] -> [LTcSpecPrag] -> [LForeignDecl TcId]
-            -> TcM ([Id], 
-                    Bag EvBind,
-                    Bag (LHsBind  Id),
-                    [LForeignDecl Id],
-                    [LTcSpecPrag],
-                    [LRuleDecl    Id])
-zonkTopDecls ev_binds binds sig_ns rules imp_specs fords
-  = do { (env1, ev_binds') <- zonkEvBinds emptyZonkEnv ev_binds
+             -> [LRuleDecl TcId] -> [LVectDecl TcId] -> [LTcSpecPrag] -> [LForeignDecl TcId]
+             -> TcM ([Id], 
+                     Bag EvBind,
+                     Bag (LHsBind  Id),
+                     [LForeignDecl Id],
+                     [LTcSpecPrag],
+                     [LRuleDecl    Id],
+                     [LVectDecl    Id])
+zonkTopDecls ev_binds binds sig_ns rules vects imp_specs fords
+  = do  { (env1, ev_binds') <- zonkEvBinds emptyZonkEnv ev_binds

 
         -- Warn about missing signatures
         -- Do this only when we we have a type to offer
 
         -- Warn about missing signatures
         -- Do this only when we we have a type to offer

@@ -286,11 +287,12 @@ zonkTopDecls ev_binds binds sig_ns rules imp_specs fords
                        | otherwise         = noSigWarn
 
         ; (env2, binds') <- zonkRecMonoBinds env1 sig_warn binds
                        | otherwise         = noSigWarn
 
         ; (env2, binds') <- zonkRecMonoBinds env1 sig_warn binds

-                       -- Top level is implicitly recursive
-       ; rules' <- zonkRules env2 rules
+                        -- Top level is implicitly recursive
+        ; rules' <- zonkRules env2 rules
+        ; vects' <- zonkVects env2 vects

         ; specs' <- zonkLTcSpecPrags env2 imp_specs
         ; specs' <- zonkLTcSpecPrags env2 imp_specs

-       ; fords' <- zonkForeignExports env2 fords
-       ; return (zonkEnvIds env2, ev_binds', binds', fords', specs', rules') }
+        ; fords' <- zonkForeignExports env2 fords
+        ; return (zonkEnvIds env2, ev_binds', binds', fords', specs', rules', vects') }

 
 ---------------------------------------------
 zonkLocalBinds :: ZonkEnv -> HsLocalBinds TcId -> TcM (ZonkEnv, HsLocalBinds Id)
 
 ---------------------------------------------
 zonkLocalBinds :: ZonkEnv -> HsLocalBinds TcId -> TcM (ZonkEnv, HsLocalBinds Id)

@@ -1006,6 +1008,21 @@ zonkRule env (HsRule name act (vars{-::[RuleBndr TcId]-}) lhs fv_lhs rhs fv_rhs)
      | otherwise  = ASSERT( isImmutableTyVar v) return (env, v)
 \end{code}
 
      | otherwise  = ASSERT( isImmutableTyVar v) return (env, v)
 \end{code}
 

+\begin{code}
+zonkVects :: ZonkEnv -> [LVectDecl TcId] -> TcM [LVectDecl Id]
+zonkVects env = mappM (wrapLocM (zonkVect env))
+
+zonkVect :: ZonkEnv -> VectDecl TcId -> TcM (VectDecl Id)
+zonkVect env (HsVect v Nothing)
+  = do { v' <- wrapLocM (zonkIdBndr env) v
+       ; return $ HsVect v' Nothing
+       }
+zonkVect env (HsVect v (Just e))
+  = do { v' <- wrapLocM (zonkIdBndr env) v
+       ; e' <- zonkLExpr env e
+       ; return $ HsVect v' (Just e')
+       }
+\end{code}

 
 %************************************************************************
 %*                                                                     *
 
 %************************************************************************
 %*                                                                     *

diff --git a/compiler/typecheck/TcInteract.lhs b/compiler/typecheck/TcInteract.lhs
index 3f166cf..4889e38 100644 (file)
--- a/compiler/typecheck/TcInteract.lhs
+++ b/compiler/typecheck/TcInteract.lhs
@@ -365,7 +365,8 @@ solveInteract inert ws
                                                    -> (ct,evVarPred ev)) ws)
               , text "inert = " <+> ppr inert ]
 
                                                    -> (ct,evVarPred ev)) ws)
               , text "inert = " <+> ppr inert ]
 

-       ; (flag, inert_ret) <- foldlBagM (tryPreSolveAndInteract sctx dyn_flags) (True,inert) ws 
+       ; (flag, inert_ret) <- foldrBagM (tryPreSolveAndInteract sctx dyn_flags) (True,inert) ws 
+                        -- use foldr to preserve the order

 
        ; traceTcS "solveInteract, after clever canonicalization (and interaction):" $
          vcat [ text "No interaction happened = " <+> ppr flag
 
        ; traceTcS "solveInteract, after clever canonicalization (and interaction):" $
          vcat [ text "No interaction happened = " <+> ppr flag

@@ -376,12 +377,11 @@ solveInteract inert ws
 
 tryPreSolveAndInteract :: SimplContext
                        -> DynFlags
 
 tryPreSolveAndInteract :: SimplContext
                        -> DynFlags

-                       -> (Bool, InertSet)

                        -> FlavoredEvVar
                        -> FlavoredEvVar

+                       -> (Bool, InertSet)

                        -> TcS (Bool, InertSet)
 -- Returns: True if it was able to discharge this constraint AND all previous ones
                        -> TcS (Bool, InertSet)
 -- Returns: True if it was able to discharge this constraint AND all previous ones

-tryPreSolveAndInteract sctx dyn_flags (all_previous_discharged, inert)
-                       flavev@(EvVarX ev_var fl)
+tryPreSolveAndInteract sctx dyn_flags flavev@(EvVarX ev_var fl) (all_previous_discharged, inert)

   = do { let inert_cts = get_inert_cts (evVarPred ev_var)
 
        ; this_one_discharged <- dischargeFromCCans inert_cts flavev
   = do { let inert_cts = get_inert_cts (evVarPred ev_var)
 
        ; this_one_discharged <- dischargeFromCCans inert_cts flavev

@@ -391,8 +391,7 @@ tryPreSolveAndInteract sctx dyn_flags (all_previous_discharged, inert)
 
          else do
        { extra_cts <- mkCanonical fl ev_var
 
          else do
        { extra_cts <- mkCanonical fl ev_var

-       ; inert_ret <- solveInteractWithDepth (ctxtStkDepth dyn_flags,0,[])
-                                             inert extra_cts
+       ; inert_ret <- solveInteractWithDepth (ctxtStkDepth dyn_flags,0,[]) extra_cts inert

        ; return (False, inert_ret) } }
 
   where
        ; return (False, inert_ret) } }
 
   where

@@ -439,16 +438,16 @@ canonicals. If so, we add nothing to the returned canonical
 constraints.
 
 \begin{code}
 constraints.
 
 \begin{code}

-solveOne :: InertSet -> WorkItem -> TcS InertSet 
-solveOne inerts workItem 
+solveOne :: WorkItem -> InertSet -> TcS InertSet 
+solveOne workItem inerts 

   = do { dyn_flags <- getDynFlags
   = do { dyn_flags <- getDynFlags

-       ; solveOneWithDepth (ctxtStkDepth dyn_flags,0,[]) inerts workItem
+       ; solveOneWithDepth (ctxtStkDepth dyn_flags,0,[]) workItem inerts

        }
 
 -----------------
 solveInteractWithDepth :: (Int, Int, [WorkItem])
        }
 
 -----------------
 solveInteractWithDepth :: (Int, Int, [WorkItem])

-                       -> InertSet -> WorkList -> TcS InertSet
-solveInteractWithDepth ctxt@(max_depth,n,stack) inert ws 
+                       -> WorkList -> InertSet -> TcS InertSet
+solveInteractWithDepth ctxt@(max_depth,n,stack) ws inert

   | isEmptyWorkList ws
   = return inert
 
   | isEmptyWorkList ws
   = return inert
 

@@ -458,26 +457,27 @@ solveInteractWithDepth ctxt@(max_depth,n,stack) inert ws
   | otherwise 
   = do { traceTcS "solveInteractWithDepth" $ 
               vcat [ text "Current depth =" <+> ppr n
   | otherwise 
   = do { traceTcS "solveInteractWithDepth" $ 
               vcat [ text "Current depth =" <+> ppr n

-                   , text "Max depth =" <+> ppr max_depth ]
+                   , text "Max depth =" <+> ppr max_depth
+                   , text "ws =" <+> ppr ws ]

 
              -- Solve equalities first
        ; let (eqs, non_eqs) = Bag.partitionBag isCTyEqCan ws
 
              -- Solve equalities first
        ; let (eqs, non_eqs) = Bag.partitionBag isCTyEqCan ws

-       ; is_from_eqs <- Bag.foldlBagM (solveOneWithDepth ctxt) inert eqs
-       ; Bag.foldlBagM (solveOneWithDepth ctxt) is_from_eqs non_eqs }
+       ; is_from_eqs <- Bag.foldrBagM (solveOneWithDepth ctxt) inert eqs
+       ; Bag.foldrBagM (solveOneWithDepth ctxt) is_from_eqs non_eqs }
+                        -- use foldr to preserve the order

 
 ------------------
 -- Fully interact the given work item with an inert set, and return a
 -- new inert set which has assimilated the new information.
 solveOneWithDepth :: (Int, Int, [WorkItem])
 
 ------------------
 -- Fully interact the given work item with an inert set, and return a
 -- new inert set which has assimilated the new information.
 solveOneWithDepth :: (Int, Int, [WorkItem])

-                  -> InertSet -> WorkItem -> TcS InertSet
-solveOneWithDepth (max_depth, depth, stack) inert work
+                  -> WorkItem -> InertSet -> TcS InertSet
+solveOneWithDepth (max_depth, depth, stack) work inert

   = do { traceFireTcS depth (text "Solving {" <+> ppr work)
        ; (new_inert, new_work) <- runSolverPipeline depth thePipeline inert work
          
         -- Recursively solve the new work generated 
          -- from workItem, with a greater depth
   = do { traceFireTcS depth (text "Solving {" <+> ppr work)
        ; (new_inert, new_work) <- runSolverPipeline depth thePipeline inert work
          
         -- Recursively solve the new work generated 
          -- from workItem, with a greater depth

-       ; res_inert <- solveInteractWithDepth (max_depth, depth+1, work:stack)
-                                new_inert new_work 
+       ; res_inert <- solveInteractWithDepth (max_depth, depth+1, work:stack) new_work new_inert 

 
        ; traceFireTcS depth (text "Done }" <+> ppr work) 
 
 
        ; traceFireTcS depth (text "Done }" <+> ppr work) 
 

@@ -796,7 +796,8 @@ data WhichComesFromInert = LeftComesFromInert | RightComesFromInert
 
 interactWithInertEqsStage :: SimplifierStage 
 interactWithInertEqsStage depth workItem inert
 
 interactWithInertEqsStage :: SimplifierStage 
 interactWithInertEqsStage depth workItem inert

-  = Bag.foldlBagM (interactNext depth) initITR (inert_eqs inert)
+  = Bag.foldrBagM (interactNext depth) initITR (inert_eqs inert)
+                        -- use foldr to preserve the order

   where
     initITR = SR { sr_inerts   = inert { inert_eqs = emptyCCan }
                  , sr_new_work = emptyWorkList
   where
     initITR = SR { sr_inerts   = inert { inert_eqs = emptyCCan }
                  , sr_new_work = emptyWorkList

@@ -814,7 +815,8 @@ interactWithInertsStage depth workItem inert
         initITR = SR { sr_inerts   = inert_residual
                      , sr_new_work = emptyWorkList
                      , sr_stop     = ContinueWith workItem } 
         initITR = SR { sr_inerts   = inert_residual
                      , sr_new_work = emptyWorkList
                      , sr_stop     = ContinueWith workItem } 

-    in Bag.foldlBagM (interactNext depth) initITR relevant 
+    in Bag.foldrBagM (interactNext depth) initITR relevant 
+                        -- use foldr to preserve the order

   where 
     getISRelevant :: CanonicalCt -> InertSet -> (CanonicalCts, InertSet) 
     getISRelevant (CFrozenErr {}) is = (emptyCCan, is)
   where 
     getISRelevant :: CanonicalCt -> InertSet -> (CanonicalCts, InertSet) 
     getISRelevant (CFrozenErr {}) is = (emptyCCan, is)

@@ -841,8 +843,8 @@ interactWithInertsStage depth workItem inert
                     , inert_ips    = emptyCCanMap
                     , inert_funeqs = emptyCCanMap })
 
                     , inert_ips    = emptyCCanMap
                     , inert_funeqs = emptyCCanMap })
 

-interactNext :: SubGoalDepth -> StageResult -> AtomicInert -> TcS StageResult 
-interactNext depth it inert  
+interactNext :: SubGoalDepth -> AtomicInert -> StageResult -> TcS StageResult 
+interactNext depth inert it

   | ContinueWith work_item <- sr_stop it
   = do { let inerts = sr_inerts it 
 
   | ContinueWith work_item <- sr_stop it
   = do { let inerts = sr_inerts it 
 

diff --git a/compiler/typecheck/TcRnDriver.lhs b/compiler/typecheck/TcRnDriver.lhs
index 38c4d7a..3de19ed 100644 (file)
--- a/compiler/typecheck/TcRnDriver.lhs
+++ b/compiler/typecheck/TcRnDriver.lhs
@@ -2,7 +2,7 @@
 % (c) The University of Glasgow 2006
 % (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
 %
 % (c) The University of Glasgow 2006
 % (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
 %

-\section[TcModule]{Typechecking a whole module}
+\section[TcMovectle]{Typechecking a whole module}

 
 \begin{code}
 module TcRnDriver (
 
 \begin{code}
 module TcRnDriver (

@@ -328,6 +328,7 @@ tcRnExtCore hsc_env (HsExtCore this_mod decls src_binds)
                                mg_inst_env  = tcg_inst_env tcg_env,
                                mg_fam_inst_env = tcg_fam_inst_env tcg_env,
                                mg_rules     = [],
                                mg_inst_env  = tcg_inst_env tcg_env,
                                mg_fam_inst_env = tcg_fam_inst_env tcg_env,
                                mg_rules     = [],

+                               mg_vect_decls = [],

                                mg_anns      = [],
                                mg_binds     = core_binds,
 
                                mg_anns      = [],
                                mg_binds     = core_binds,
 

@@ -390,30 +391,32 @@ tcRnSrcDecls boot_iface decls
                        -- It's a waste of time; and we may get debug warnings
                        -- about strangely-typed TyCons!
 
                        -- It's a waste of time; and we may get debug warnings
                        -- about strangely-typed TyCons!
 

-       -- Zonk the final code.  This must be done last.
-       -- Even simplifyTop may do some unification.
+        -- Zonk the final code.  This must be done last.
+        -- Even simplifyTop may do some unification.

         -- This pass also warns about missing type signatures
         -- This pass also warns about missing type signatures

-       let { (tcg_env, _) = tc_envs
-           ; TcGblEnv { tcg_type_env  = type_env,
-                        tcg_binds     = binds,
-                        tcg_sigs      = sig_ns,
-                        tcg_ev_binds  = cur_ev_binds,
-                        tcg_imp_specs = imp_specs,
-                        tcg_rules     = rules,
-                        tcg_fords     = fords } = tcg_env
+        let { (tcg_env, _) = tc_envs
+            ; TcGblEnv { tcg_type_env  = type_env,
+                         tcg_binds     = binds,
+                         tcg_sigs      = sig_ns,
+                         tcg_ev_binds  = cur_ev_binds,
+                         tcg_imp_specs = imp_specs,
+                         tcg_rules     = rules,
+                         tcg_vects     = vects,
+                         tcg_fords     = fords } = tcg_env

             ; all_ev_binds = cur_ev_binds `unionBags` new_ev_binds } ;
 
             ; all_ev_binds = cur_ev_binds `unionBags` new_ev_binds } ;
 

-       (bind_ids, ev_binds', binds', fords', imp_specs', rules') 
-            <- zonkTopDecls all_ev_binds binds sig_ns rules imp_specs fords ;
-       
-       let { final_type_env = extendTypeEnvWithIds type_env bind_ids
-           ; tcg_env' = tcg_env { tcg_binds    = binds',
-                                  tcg_ev_binds = ev_binds',
-                                  tcg_imp_specs = imp_specs',
-                                  tcg_rules    = rules', 
-                                  tcg_fords    = fords' } } ;
-
-        setGlobalTypeEnv tcg_env' final_type_env                                  
+        (bind_ids, ev_binds', binds', fords', imp_specs', rules', vects') 
+            <- zonkTopDecls all_ev_binds binds sig_ns rules vects imp_specs fords ;
+        
+        let { final_type_env = extendTypeEnvWithIds type_env bind_ids
+            ; tcg_env' = tcg_env { tcg_binds    = binds',
+                                   tcg_ev_binds = ev_binds',
+                                   tcg_imp_specs = imp_specs',
+                                   tcg_rules    = rules', 
+                                   tcg_vects    = vects', 
+                                   tcg_fords    = fords' } } ;
+
+        setGlobalTypeEnv tcg_env' final_type_env                                   

    } }
 
 tc_rn_src_decls :: ModDetails -> [LHsDecl RdrName] -> TcM (TcGblEnv, TcLclEnv)
    } }
 
 tc_rn_src_decls :: ModDetails -> [LHsDecl RdrName] -> TcM (TcGblEnv, TcLclEnv)

@@ -480,6 +483,7 @@ tcRnHsBootDecls decls
                   hs_fords  = for_decls,
                   hs_defds  = def_decls,  
                   hs_ruleds = rule_decls, 
                   hs_fords  = for_decls,
                   hs_defds  = def_decls,  
                   hs_ruleds = rule_decls, 

+                  hs_vects  = vect_decls, 

                   hs_annds  = _,
                   hs_valds  = val_binds }) <- rnTopSrcDecls first_group
        ; (gbl_env, lie) <- captureConstraints $ setGblEnv tcg_env $ do {
                   hs_annds  = _,
                   hs_valds  = val_binds }) <- rnTopSrcDecls first_group
        ; (gbl_env, lie) <- captureConstraints $ setGblEnv tcg_env $ do {

@@ -492,6 +496,7 @@ tcRnHsBootDecls decls
        ; mapM_ (badBootDecl "foreign") for_decls
        ; mapM_ (badBootDecl "default") def_decls
        ; mapM_ (badBootDecl "rule")    rule_decls
        ; mapM_ (badBootDecl "foreign") for_decls
        ; mapM_ (badBootDecl "default") def_decls
        ; mapM_ (badBootDecl "rule")    rule_decls

+       ; mapM_ (badBootDecl "vect")    vect_decls

 
                -- Typecheck type/class decls
        ; traceTc "Tc2" empty
 
                -- Typecheck type/class decls
        ; traceTc "Tc2" empty

@@ -836,6 +841,7 @@ tcTopSrcDecls boot_details
                   hs_defds  = default_decls,
                   hs_annds  = annotation_decls,
                   hs_ruleds = rule_decls,
                   hs_defds  = default_decls,
                   hs_annds  = annotation_decls,
                   hs_ruleds = rule_decls,

+                  hs_vects  = vect_decls,

                   hs_valds  = val_binds })
  = do {                -- Type-check the type and class decls, and all imported decls
                -- The latter come in via tycl_decls
                   hs_valds  = val_binds })
  = do {                -- Type-check the type and class decls, and all imported decls
                -- The latter come in via tycl_decls

@@ -878,21 +884,24 @@ tcTopSrcDecls boot_details
 
         setLclTypeEnv tcl_env $ do {   -- Environment doesn't change now
 
 
         setLclTypeEnv tcl_env $ do {   -- Environment doesn't change now
 

-               -- Second pass over class and instance declarations, 
+                -- Second pass over class and instance declarations, 

         traceTc "Tc6" empty ;
         traceTc "Tc6" empty ;

-       inst_binds <- tcInstDecls2 (concat tycl_decls) inst_infos ;
+        inst_binds <- tcInstDecls2 (concat tycl_decls) inst_infos ;

 
 

-               -- Foreign exports
+                -- Foreign exports

         traceTc "Tc7" empty ;
         traceTc "Tc7" empty ;

-       (foe_binds, foe_decls) <- tcForeignExports foreign_decls ;
+        (foe_binds, foe_decls) <- tcForeignExports foreign_decls ;

 
                 -- Annotations
 
                 -- Annotations

-       annotations <- tcAnnotations annotation_decls ;
+        annotations <- tcAnnotations annotation_decls ;

 
 

-               -- Rules
-       rules <- tcRules rule_decls ;
+                -- Rules
+        rules <- tcRules rule_decls ;

 
 

-               -- Wrap up
+                -- Vectorisation declarations
+        vects <- tcVectDecls vect_decls ;
+
+                -- Wrap up

         traceTc "Tc7a" empty ;
        tcg_env <- getGblEnv ;
        let { all_binds = tc_val_binds   `unionBags`
         traceTc "Tc7a" empty ;
        tcg_env <- getGblEnv ;
        let { all_binds = tc_val_binds   `unionBags`

@@ -904,15 +913,17 @@ tcTopSrcDecls boot_details
             ; sig_names = mkNameSet (collectHsValBinders val_binds) 
                           `minusNameSet` getTypeSigNames val_binds
 
             ; sig_names = mkNameSet (collectHsValBinders val_binds) 
                           `minusNameSet` getTypeSigNames val_binds
 

-               -- Extend the GblEnv with the (as yet un-zonked) 
-               -- bindings, rules, foreign decls
-           ; tcg_env' = tcg_env { tcg_binds = tcg_binds tcg_env `unionBags` all_binds
-                                , tcg_imp_specs = tcg_imp_specs tcg_env ++ specs1 ++ specs2 ++ specs3
+                -- Extend the GblEnv with the (as yet un-zonked) 
+                -- bindings, rules, foreign decls
+            ; tcg_env' = tcg_env { tcg_binds = tcg_binds tcg_env `unionBags` all_binds
+                                 , tcg_imp_specs = tcg_imp_specs tcg_env ++ specs1 ++ specs2 ++
+                                                   specs3

                                  , tcg_sigs  = tcg_sigs tcg_env `unionNameSets` sig_names
                                  , tcg_sigs  = tcg_sigs tcg_env `unionNameSets` sig_names

-                                , tcg_rules = tcg_rules tcg_env ++ rules
-                                , tcg_anns  = tcg_anns tcg_env ++ annotations
-                                , tcg_fords = tcg_fords tcg_env ++ foe_decls ++ fi_decls } } ;
-       return (tcg_env', tcl_env)
+                                 , tcg_rules = tcg_rules tcg_env ++ rules
+                                 , tcg_vects = tcg_vects tcg_env ++ vects
+                                 , tcg_anns  = tcg_anns tcg_env ++ annotations
+                                 , tcg_fords = tcg_fords tcg_env ++ foe_decls ++ fi_decls } } ;
+        return (tcg_env', tcl_env)

     }}}}}}
 \end{code}
 
     }}}}}}
 \end{code}
 

@@ -1563,18 +1574,20 @@ tcCoreDump mod_guts
 -- It's unpleasant having both pprModGuts and pprModDetails here
 pprTcGblEnv :: TcGblEnv -> SDoc
 pprTcGblEnv (TcGblEnv { tcg_type_env  = type_env, 
 -- It's unpleasant having both pprModGuts and pprModDetails here
 pprTcGblEnv :: TcGblEnv -> SDoc
 pprTcGblEnv (TcGblEnv { tcg_type_env  = type_env, 

-                       tcg_insts     = insts, 
-                       tcg_fam_insts = fam_insts, 
-                       tcg_rules     = rules,
-                       tcg_imports   = imports })
+                        tcg_insts     = insts, 
+                        tcg_fam_insts = fam_insts, 
+                        tcg_rules     = rules,
+                        tcg_vects     = vects,
+                        tcg_imports   = imports })

   = vcat [ ppr_types insts type_env
         , ppr_tycons fam_insts type_env
   = vcat [ ppr_types insts type_env
         , ppr_tycons fam_insts type_env

-        , ppr_insts insts
-        , ppr_fam_insts fam_insts
-        , vcat (map ppr rules)
-        , ppr_gen_tycons (typeEnvTyCons type_env)
-        , ptext (sLit "Dependent modules:") <+> 
-               ppr (sortBy cmp_mp $ eltsUFM (imp_dep_mods imports))
+         , ppr_insts insts
+         , ppr_fam_insts fam_insts
+         , vcat (map ppr rules)
+         , vcat (map ppr vects)
+         , ppr_gen_tycons (typeEnvTyCons type_env)
+         , ptext (sLit "Dependent modules:") <+> 
+                ppr (sortBy cmp_mp $ eltsUFM (imp_dep_mods imports))

         , ptext (sLit "Dependent packages:") <+> 
                ppr (sortBy stablePackageIdCmp $ imp_dep_pkgs imports)]
   where                -- The two uses of sortBy are just to reduce unnecessary
         , ptext (sLit "Dependent packages:") <+> 
                ppr (sortBy stablePackageIdCmp $ imp_dep_pkgs imports)]
   where                -- The two uses of sortBy are just to reduce unnecessary

diff --git a/compiler/typecheck/TcRnMonad.lhs b/compiler/typecheck/TcRnMonad.lhs
index 37e1166..ad2405b 100644 (file)
--- a/compiler/typecheck/TcRnMonad.lhs
+++ b/compiler/typecheck/TcRnMonad.lhs
@@ -114,11 +114,12 @@ initTc hsc_env hsc_src keep_rn_syntax mod do_this
                tcg_warns     = NoWarnings,
                tcg_anns      = [],
                tcg_insts     = [],
                tcg_warns     = NoWarnings,
                tcg_anns      = [],
                tcg_insts     = [],

-               tcg_fam_insts = [],
-               tcg_rules     = [],
-               tcg_fords     = [],
-               tcg_dfun_n    = dfun_n_var,
-               tcg_keep      = keep_var,
+                tcg_fam_insts = [],
+                tcg_rules     = [],
+                tcg_fords     = [],
+                tcg_vects     = [],
+                tcg_dfun_n    = dfun_n_var,
+                tcg_keep      = keep_var,

                tcg_doc_hdr   = Nothing,
                 tcg_hpc       = False,
                 tcg_main      = Nothing
                tcg_doc_hdr   = Nothing,
                 tcg_hpc       = False,
                 tcg_main      = Nothing

diff --git a/compiler/typecheck/TcRnTypes.lhs b/compiler/typecheck/TcRnTypes.lhs
index f9422a8..3367f06 100644 (file)
--- a/compiler/typecheck/TcRnTypes.lhs
+++ b/compiler/typecheck/TcRnTypes.lhs
@@ -260,9 +260,10 @@ data TcGblEnv
        tcg_warns     :: Warnings,          -- ...Warnings and deprecations
        tcg_anns      :: [Annotation],      -- ...Annotations
        tcg_insts     :: [Instance],        -- ...Instances
        tcg_warns     :: Warnings,          -- ...Warnings and deprecations
        tcg_anns      :: [Annotation],      -- ...Annotations
        tcg_insts     :: [Instance],        -- ...Instances

-       tcg_fam_insts :: [FamInst],         -- ...Family instances
-       tcg_rules     :: [LRuleDecl Id],    -- ...Rules
-       tcg_fords     :: [LForeignDecl Id], -- ...Foreign import & exports
+        tcg_fam_insts :: [FamInst],         -- ...Family instances
+        tcg_rules     :: [LRuleDecl Id],    -- ...Rules
+        tcg_fords     :: [LForeignDecl Id], -- ...Foreign import & exports
+        tcg_vects     :: [LVectDecl Id],    -- ...Vectorisation declarations

 
        tcg_doc_hdr   :: Maybe LHsDocString, -- ^ Maybe Haddock header docs
         tcg_hpc       :: AnyHpcUsage,        -- ^ @True@ if any part of the
 
        tcg_doc_hdr   :: Maybe LHsDocString, -- ^ Maybe Haddock header docs
         tcg_hpc       :: AnyHpcUsage,        -- ^ @True@ if any part of the

@@ -714,10 +715,10 @@ andWC (WC { wc_flat = f1, wc_impl = i1, wc_insol = n1 })
        , wc_insol = n1 `unionBags` n2 }
 
 addFlats :: WantedConstraints -> Bag WantedEvVar -> WantedConstraints
        , wc_insol = n1 `unionBags` n2 }
 
 addFlats :: WantedConstraints -> Bag WantedEvVar -> WantedConstraints

-addFlats wc wevs = wc { wc_flat = wevs `unionBags` wc_flat wc }
+addFlats wc wevs = wc { wc_flat = wc_flat wc `unionBags` wevs }

 
 addImplics :: WantedConstraints -> Bag Implication -> WantedConstraints
 
 addImplics :: WantedConstraints -> Bag Implication -> WantedConstraints

-addImplics wc implic = wc { wc_impl = implic `unionBags` wc_impl wc }
+addImplics wc implic = wc { wc_impl = wc_impl wc `unionBags` implic }

 
 instance Outputable WantedConstraints where
   ppr (WC {wc_flat = f, wc_impl = i, wc_insol = n})
 
 instance Outputable WantedConstraints where
   ppr (WC {wc_flat = f, wc_impl = i, wc_insol = n})

@@ -883,11 +884,12 @@ wantedToFlavored (EvVarX v wl) = EvVarX v (Wanted wl)
 
 keepWanted :: Bag FlavoredEvVar -> Bag WantedEvVar
 keepWanted flevs
 
 keepWanted :: Bag FlavoredEvVar -> Bag WantedEvVar
 keepWanted flevs

-  = foldlBag keep_wanted emptyBag flevs
+  = foldrBag keep_wanted emptyBag flevs
+    -- Important: use fold*r*Bag to preserve the order of the evidence variables.

   where
   where

-    keep_wanted :: Bag WantedEvVar -> FlavoredEvVar -> Bag WantedEvVar
-    keep_wanted r (EvVarX ev (Wanted wloc)) = consBag (EvVarX ev wloc) r
-    keep_wanted r _ = r
+    keep_wanted :: FlavoredEvVar -> Bag WantedEvVar -> Bag WantedEvVar
+    keep_wanted (EvVarX ev (Wanted wloc)) r = consBag (EvVarX ev wloc) r
+    keep_wanted _                         r = r

 \end{code}
 
 
 \end{code}
 
 

diff --git a/compiler/utils/Bag.lhs b/compiler/utils/Bag.lhs
index bb0f104..097a112 100644 (file)
--- a/compiler/utils/Bag.lhs
+++ b/compiler/utils/Bag.lhs
@@ -16,7 +16,7 @@ module Bag (
         concatBag, foldBag, foldrBag, foldlBag,
         isEmptyBag, isSingletonBag, consBag, snocBag, anyBag,
         listToBag, bagToList,
         concatBag, foldBag, foldrBag, foldlBag,
         isEmptyBag, isSingletonBag, consBag, snocBag, anyBag,
         listToBag, bagToList,

-        foldlBagM, mapBagM, mapBagM_, 
+        foldrBagM, foldlBagM, mapBagM, mapBagM_, 

         flatMapBagM, flatMapBagPairM,
         mapAndUnzipBagM, mapAccumBagLM
     ) where
         flatMapBagM, flatMapBagPairM,
         mapAndUnzipBagM, mapAccumBagLM
     ) where

@@ -171,6 +171,12 @@ foldlBag k z (UnitBag x)     = k z x
 foldlBag k z (TwoBags b1 b2) = foldlBag k (foldlBag k z b1) b2
 foldlBag k z (ListBag xs)    = foldl k z xs
 
 foldlBag k z (TwoBags b1 b2) = foldlBag k (foldlBag k z b1) b2
 foldlBag k z (ListBag xs)    = foldl k z xs
 

+foldrBagM :: (Monad m) => (a -> b -> m b) -> b -> Bag a -> m b
+foldrBagM _ z EmptyBag        = return z
+foldrBagM k z (UnitBag x)     = k x z
+foldrBagM k z (TwoBags b1 b2) = do { z' <- foldrBagM k z b2; foldrBagM k z' b1 }
+foldrBagM k z (ListBag xs)    = foldrM k z xs
+

 foldlBagM :: (Monad m) => (b -> a -> m b) -> b -> Bag a -> m b
 foldlBagM _ z EmptyBag        = return z
 foldlBagM k z (UnitBag x)     = k z x
 foldlBagM :: (Monad m) => (b -> a -> m b) -> b -> Bag a -> m b
 foldlBagM _ z EmptyBag        = return z
 foldlBagM k z (UnitBag x)     = k z x

diff --git a/compiler/vectorise/Vectorise.hs b/compiler/vectorise/Vectorise.hs
index e3e9646..72cca6e 100644 (file)
--- a/compiler/vectorise/Vectorise.hs
+++ b/compiler/vectorise/Vectorise.hs
@@ -1,6 +1,6 @@
 {-# OPTIONS -fno-warn-missing-signatures #-}
 
 {-# OPTIONS -fno-warn-missing-signatures #-}
 

-module Vectorise( vectorise )
+module Vectorise ( vectorise )

 where
 
 import Vectorise.Type.Env
 where
 
 import Vectorise.Type.Env

@@ -13,14 +13,16 @@ import Vectorise.Env
 import Vectorise.Monad
 
 import HscTypes hiding      ( MonadThings(..) )
 import Vectorise.Monad
 
 import HscTypes hiding      ( MonadThings(..) )

-import Module               ( PackageId )
-import CoreSyn

 import CoreUnfold           ( mkInlineUnfolding )
 import CoreFVs
 import CoreUnfold           ( mkInlineUnfolding )
 import CoreFVs

+import PprCore
+import CoreSyn

 import CoreMonad            ( CoreM, getHscEnv )
 import CoreMonad            ( CoreM, getHscEnv )

+import Type

 import Var
 import Id
 import OccName
 import Var
 import Id
 import OccName

+import DynFlags

 import BasicTypes           ( isLoopBreaker )
 import Outputable
 import Util                 ( zipLazy )
 import BasicTypes           ( isLoopBreaker )
 import Outputable
 import Util                 ( zipLazy )

@@ -28,53 +30,58 @@ import MonadUtils
 
 import Control.Monad
 
 
 import Control.Monad
 

-debug          = False
-dtrace s x     = if debug then pprTrace "Vectorise" s x else x

 
 -- | Vectorise a single module.
 
 -- | 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.
 
 -- | Vectorise a single module, in the VM monad.

+--

 vectModule :: ModGuts -> VM ModGuts
 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
 
 
       -- 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.
 
 -- | 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
 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.
 
       -- 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.
 
       -- 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`
 
       return . Rec $ (var, cexpr) : (var', expr') : hs
   `orElseV`

@@ -132,7 +139,7 @@ vectTopBind b@(NonRec var expr)
 vectTopBind b@(Rec bs)
  = do
       (vars', _, exprs') 
 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') 
             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
     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
 -- | 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
 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
 
   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.
 -- | 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
 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,
 
 -- | 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
 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 04e768b..3647a7f 100644 (file)
--- a/compiler/vectorise/Vectorise/Builtins.hs
+++ b/compiler/vectorise/Vectorise/Builtins.hs
@@ -1,6 +1,6 @@
 
 -- | Builtin types and functions used by the vectoriser.
 
 -- | 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
 --   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 9e78f11..94de62a 100644 (file)
--- 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)
 
              $ 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.
 -- | 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
   = 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
                ++ 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]
     (cons, cmods, cfs)       = unzip3 (preludeDataCons mods)
 
     defaultDataConWorkers :: [DataCon]

@@ -273,12 +274,12 @@ initBuiltinBoxedTyCons
        builtinBoxedTyCons _ 
                = [(tyConName intPrimTyCon, intTyCon)]
 
        builtinBoxedTyCons _ 
                = [(tyConName intPrimTyCon, intTyCon)]
 

-

 -- | Get a list of all scalar functions in the mock prelude.
 -- | 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
 
 -- | 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 b578f30..b0f305d 100644 (file)
--- 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
 -- | 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
 
 
 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.
        -> [( 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_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
                      })
 
     -- 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. 
 
     -- 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"
     , 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")
 
     , 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")
     -- 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")
     , 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')
   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"
        ]
 
        , mk' mod "floor"    "floorV"
        ]
 

-

 preludeScalars :: Modules -> [(Module, FastString)]
 preludeScalars (Modules { dph_Prelude_Int    = dph_Prelude_Int
                         , dph_Prelude_Word8  = dph_Prelude_Word8
 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 70ed8c4..9a1fd44 100644 (file)
--- a/compiler/vectorise/Vectorise/Env.hs
+++ b/compiler/vectorise/Vectorise/Env.hs
@@ -20,10 +20,12 @@ module Vectorise.Env (
        setBoxedTyConsEnv,
        updVectInfo
 ) where
        setBoxedTyConsEnv,
        updVectInfo
 ) where

+

 import HscTypes
 import InstEnv
 import FamInstEnv
 import CoreSyn
 import HscTypes
 import InstEnv
 import FamInstEnv
 import CoreSyn

+import Type

 import TyCon
 import DataCon
 import VarEnv
 import TyCon
 import DataCon
 import VarEnv

@@ -70,15 +72,22 @@ emptyLocalEnv = LocalEnv {
 
 -- GlobalEnv ------------------------------------------------------------------
 -- | The global environment.
 
 -- GlobalEnv ------------------------------------------------------------------
 -- | The global environment.

---     These are things the exist at top-level.
+--      These are things the exist at top-level.

 data GlobalEnv 
 data GlobalEnv 

-       = GlobalEnv {
+        = GlobalEnv {

         -- | Mapping from global variables to their vectorised versions.
         -- | 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)
 
         -- | 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_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.
 
         -- | 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
 
         -- | Mapping from TyCons to their PR dfuns.
         , global_pr_funs       :: NameEnv Var

@@ -109,24 +118,26 @@ data GlobalEnv
         , global_bindings      :: [(Var, CoreExpr)]
         }
 
         , global_bindings      :: [(Var, CoreExpr)]
         }
 

-

 -- | Create an initial global environment
 -- | 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 -------------------------------------------
 
 
 -- Operators on Global Environments -------------------------------------------

@@ -135,13 +146,11 @@ extendImportedVarsEnv :: [(Var, Var)] -> GlobalEnv -> GlobalEnv
 extendImportedVarsEnv ps genv
   = genv { global_vars  = extendVarEnvList (global_vars genv) ps }
 
 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 }
 
 -- | 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
 -- | 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 9cd34e3..569057e 100644 (file)
--- a/compiler/vectorise/Vectorise/Exp.hs
+++ b/compiler/vectorise/Vectorise/Exp.hs
@@ -33,17 +33,15 @@ import Data.List
 
 
 -- | Vectorise a polymorphic expression.
 
 
 -- | 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 (_, 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
 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)
 
 
 vectExpr e = cantVectorise "Can't vectorise expression (vectExpr)" (ppr $ deAnnotate e)
 

-

 -- | Vectorise an expression with an outer lambda abstraction.
 -- | 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 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)
 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 2597430..5fcd2ac 100644 (file)
--- a/compiler/vectorise/Vectorise/Monad.hs
+++ b/compiler/vectorise/Vectorise/Monad.hs
@@ -22,8 +22,8 @@ module Vectorise.Monad (
        -- * Primitives
        lookupPrimPArray,
        lookupPrimMethod
        -- * Primitives
        lookupPrimPArray,
        lookupPrimMethod

-)
-where
+) where
+

 import Vectorise.Monad.Base
 import Vectorise.Monad.Naming
 import Vectorise.Monad.Local
 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 Vectorise.Builtins
 import Vectorise.Env
 

-import HscTypes hiding  ( MonadThings(..) )
+import HscTypes hiding ( MonadThings(..) )
+import DynFlags

 import MonadUtils (liftIO)
 import MonadUtils (liftIO)

-import Module

 import TyCon
 import Var
 import VarEnv
 import Id
 import DsMonad
 import Outputable
 import TyCon
 import Var
 import VarEnv
 import Id
 import DsMonad
 import Outputable

+import FastString
+

 import Control.Monad
 import VarSet
 
 -- | Run a vectorisation computation.
 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 
   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
 
 
     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.
 
 -- 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)
 
        | 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 
 
 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 
      
 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 -----------------------------------------------------------------
      
      
 -- Primitives -----------------------------------------------------------------

diff --git a/compiler/vectorise/Vectorise/Monad/Base.hs b/compiler/vectorise/Vectorise/Monad/Base.hs
index c2c314f..aa73e25 100644 (file)
--- a/compiler/vectorise/Vectorise/Monad/Base.hs
+++ b/compiler/vectorise/Vectorise/Monad/Base.hs
@@ -13,6 +13,9 @@ module Vectorise.Monad.Base (
        maybeCantVectorise,
        maybeCantVectoriseM,
        
        maybeCantVectorise,
        maybeCantVectoriseM,
        

+       -- * Debugging
+       traceVt, dumpOptVt, dumpVt,
+       

        -- * Control
        noV,     traceNoV,
        ensureV, traceEnsureV,
        -- * Control
        noV,     traceNoV,
        ensureV, traceEnsureV,

@@ -22,14 +25,23 @@ module Vectorise.Monad.Base (
        orElseV,
        fixV,
 ) where
        orElseV,
        fixV,
 ) where

+

 import Vectorise.Builtins
 import Vectorise.Env
 
 import DsMonad
 import Vectorise.Builtins
 import Vectorise.Env
 
 import DsMonad

+import TcRnMonad
+import ErrUtils

 import Outputable
 import Outputable

-       
+import DynFlags
+import StaticFlags
+
+import Control.Monad
+import System.IO (stderr)
+

 
 -- The Vectorisation Monad ----------------------------------------------------
 
 -- The Vectorisation Monad ----------------------------------------------------

+

 -- | Vectorisation can either succeed with new envionment and a value,
 --   or return with failure.
 data VResult a 
 -- | 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
 
                                         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.
 
 -- 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
 
         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
 -- 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 4bd6c77..ae68ffb 100644 (file)
--- a/compiler/vectorise/Vectorise/Monad/Global.hs
+++ b/compiler/vectorise/Vectorise/Monad/Global.hs
@@ -4,11 +4,14 @@ module Vectorise.Monad.Global (
        setGEnv,
        updGEnv,
        
        setGEnv,
        updGEnv,
        

-       -- * Vars
-       defGlobalVar,
-       
-       -- * Scalars
-       globalScalars,
+  -- * Vars
+  defGlobalVar,
+  
+  -- * Vectorisation declarations
+  lookupVectDecl,
+  
+  -- * Scalars
+  globalScalars, isGlobalScalar,

        
        -- * TyCons
        lookupTyCon,
        
        -- * TyCons
        lookupTyCon,

@@ -27,8 +30,12 @@ module Vectorise.Monad.Global (
        -- * PR Dictionaries
        lookupTyConPR
 ) where
        -- * PR Dictionaries
        lookupTyConPR
 ) where

+

 import Vectorise.Monad.Base
 import Vectorise.Env
 import Vectorise.Monad.Base
 import Vectorise.Env

+
+import CoreSyn
+import Type

 import TyCon
 import DataCon
 import NameEnv
 import TyCon
 import DataCon
 import NameEnv

@@ -65,11 +72,20 @@ defGlobalVar v v' = updGEnv $ \env ->
             | otherwise      = 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
 -- 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 ---------------------------------------------------------------------
 
 
 -- TyCons ---------------------------------------------------------------------

diff --git a/compiler/vectorise/Vectorise/Type/Env.hs b/compiler/vectorise/Vectorise/Type/Env.hs
index 61a52bc..8484410 100644 (file)
--- 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 #-}
 {-# 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,
 
 module Vectorise.Type.Env ( 
        vectTypeEnv,

-)
-where
+) where
+  

 import Vectorise.Env
 import Vectorise.Vect
 import Vectorise.Monad
 import Vectorise.Env
 import Vectorise.Vect
 import Vectorise.Monad

@@ -42,20 +39,18 @@ import MonadUtils
 import Control.Monad
 import Data.List
 
 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.
 
 -- | 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
 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
       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]
 
    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
 
 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
 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 e62f45a..8cc2bec 100644 (file)
--- 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
 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
       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.
       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)
 
 
 vectType ty = cantVectorise "Can't vectorise type" (ppr ty)
 

diff --git a/docs/users_guide/debugging.xml b/docs/users_guide/debugging.xml
index 358be10..4db79af 100644 (file)
--- a/docs/users_guide/debugging.xml
+++ b/docs/users_guide/debugging.xml
@@ -150,6 +150,17 @@
 
            <varlistentry>
              <term>
 
            <varlistentry>
              <term>

+               <option>-ddump-vect</option>:
+                <indexterm><primary><option>-ddump-vect</option></primary></indexterm>
+             </term>
+             <listitem>
+               <para>dumps the output of the vectoriser.
+                </para>
+             </listitem>
+           </varlistentry>
+
+           <varlistentry>
+             <term>

                <option>-ddump-simpl</option>:
                 <indexterm><primary><option>-ddump-simpl</option></primary></indexterm>
              </term>
                <option>-ddump-simpl</option>:
                 <indexterm><primary><option>-ddump-simpl</option></primary></indexterm>
              </term>

@@ -350,14 +361,25 @@
       </varlistentry>
 
       <varlistentry>
       </varlistentry>
 
       <varlistentry>

-       <term>
+  <term>

           <option>-ddump-tc-trace</option>
           <indexterm><primary><option>-ddump-tc-trace</option></primary></indexterm>
         </term>
           <option>-ddump-tc-trace</option>
           <indexterm><primary><option>-ddump-tc-trace</option></primary></indexterm>
         </term>

-       <listitem>
-         <para>Make the type checker be *real* chatty about what it is
-       upto.</para>
-       </listitem>
+  <listitem>
+    <para>Make the type checker be *real* chatty about what it is
+  upto.</para>
+  </listitem>
+      </varlistentry>
+
+      <varlistentry>
+  <term>
+          <option>-ddump-vt-trace</option>
+          <indexterm><primary><option>-ddump-tv-trace</option></primary></indexterm>
+        </term>
+  <listitem>
+    <para>Make the vectoriser be *real* chatty about what it is
+  upto.</para>
+  </listitem>

       </varlistentry>
 
       <varlistentry>
       </varlistentry>
 
       <varlistentry>

diff --git a/docs/users_guide/flags.xml b/docs/users_guide/flags.xml
index 2357673..3920c8e 100644 (file)
--- a/docs/users_guide/flags.xml
+++ b/docs/users_guide/flags.xml
@@ -2345,12 +2345,18 @@ phase <replaceable>n</replaceable></entry>
              <entry>dynamic</entry>
              <entry>-</entry>
            </row>
              <entry>dynamic</entry>
              <entry>-</entry>
            </row>

-           <row>
-             <entry><option>-ddump-rules</option></entry>
-             <entry>Dump rules</entry>
-             <entry>dynamic</entry>
-             <entry>-</entry>
-           </row>
+      <row>
+        <entry><option>-ddump-rules</option></entry>
+        <entry>Dump rules</entry>
+        <entry>dynamic</entry>
+        <entry>-</entry>
+      </row>
+      <row>
+        <entry><option>-ddump-vect</option></entry>
+        <entry>Dump vectoriser input and output</entry>
+        <entry>dynamic</entry>
+        <entry>-</entry>
+      </row>

            <row>
              <entry><option>-ddump-simpl</option></entry>
              <entry>Dump final simplifier output</entry>
            <row>
              <entry><option>-ddump-simpl</option></entry>
              <entry>Dump final simplifier output</entry>

@@ -2417,12 +2423,18 @@ phase <replaceable>n</replaceable></entry>
              <entry>dynamic</entry>
              <entry>-</entry>
            </row>
              <entry>dynamic</entry>
              <entry>-</entry>
            </row>

-           <row>
-             <entry><option>-ddump-tc-trace</option></entry>
-             <entry>Trace typechecker</entry>
-             <entry>dynamic</entry>
-             <entry>-</entry>
-           </row>
+      <row>
+        <entry><option>-ddump-tc-trace</option></entry>
+        <entry>Trace typechecker</entry>
+        <entry>dynamic</entry>
+        <entry>-</entry>
+      </row>
+      <row>
+        <entry><option>-ddump-vt-trace</option></entry>
+        <entry>Trace vectoriser</entry>
+        <entry>dynamic</entry>
+        <entry>-</entry>
+      </row>

            <row>
              <entry><option>-ddump-rn-trace</option></entry>
              <entry>Trace renamer</entry>
            <row>
              <entry><option>-ddump-rn-trace</option></entry>
              <entry>Trace renamer</entry>