Command-line options for selecting DPH backend

It's -fdph-seq and -fdph-par at the moment, I'll think of a nicer setup later.

diff --git a/compiler/main/DynFlags.hs b/compiler/main/DynFlags.hs
index 931d384..637907f 100644 (file)
--- a/compiler/main/DynFlags.hs
+++ b/compiler/main/DynFlags.hs
@@ -23,6 +23,7 @@ module DynFlags (
         Option(..),
         DynLibLoader(..),
         fFlags, xFlags,
         Option(..),
         DynLibLoader(..),
         fFlags, xFlags,

+        DPHBackend(..),

 
         -- Configuration of the core-to-core and stg-to-stg phases
         CoreToDo(..),
 
         -- Configuration of the core-to-core and stg-to-stg phases
         CoreToDo(..),

@@ -310,6 +311,8 @@ data DynFlags = DynFlags {
   mainFunIs             :: Maybe String,
   ctxtStkDepth          :: Int,         -- Typechecker context stack depth
 
   mainFunIs             :: Maybe String,
   ctxtStkDepth          :: Int,         -- Typechecker context stack depth
 

+  dphBackend            :: DPHBackend,
+

   thisPackage           :: PackageId,
 
   -- ways
   thisPackage           :: PackageId,
 
   -- ways

@@ -501,6 +504,8 @@ defaultDynFlags =
         mainFunIs               = Nothing,
         ctxtStkDepth            = mAX_CONTEXT_REDUCTION_DEPTH,
 
         mainFunIs               = Nothing,
         ctxtStkDepth            = mAX_CONTEXT_REDUCTION_DEPTH,
 

+        dphBackend              = DPHPar,
+

         thisPackage             = mainPackageId,
 
         objectDir               = Nothing,
         thisPackage             = mainPackageId,
 
         objectDir               = Nothing,

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

-  | CoreDoVectorisation
+  | CoreDoVectorisation DPHBackend

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

@@ -848,7 +853,6 @@ getCoreToDo dflags
     spec_constr   = dopt Opt_SpecConstr dflags
     liberate_case = dopt Opt_LiberateCase dflags
     rule_check    = ruleCheck dflags
     spec_constr   = dopt Opt_SpecConstr dflags
     liberate_case = dopt Opt_LiberateCase dflags
     rule_check    = ruleCheck dflags

-    vectorisation = dopt Opt_Vectorise dflags

     static_args   = dopt Opt_StaticArgumentTransformation dflags
 
     maybe_rule_check phase = runMaybe rule_check (CoreDoRuleCheck phase)
     static_args   = dopt Opt_StaticArgumentTransformation dflags
 
     maybe_rule_check phase = runMaybe rule_check (CoreDoRuleCheck phase)

@@ -861,6 +865,11 @@ getCoreToDo dflags
             maybe_rule_check phase
           ]
 
             maybe_rule_check phase
           ]
 

+    vectorisation
+      = runWhen (dopt Opt_Vectorise dflags)
+        $ CoreDoPasses [ simpl_gently, CoreDoVectorisation (dphBackend dflags) ]
+
+

                 -- By default, we have 2 phases before phase 0.
 
                 -- Want to run with inline phase 2 after the specialiser to give
                 -- By default, we have 2 phases before phase 0.
 
                 -- Want to run with inline phase 2 after the specialiser to give

@@ -895,7 +904,7 @@ getCoreToDo dflags
 
     core_todo =
      if opt_level == 0 then
 
     core_todo =
      if opt_level == 0 then

-       [runWhen vectorisation (CoreDoPasses [ simpl_gently, CoreDoVectorisation ]),
+       [vectorisation,

         simpl_phase 0 ["final"] max_iter]
      else {- opt_level >= 1 -} [
 
         simpl_phase 0 ["final"] max_iter]
      else {- opt_level >= 1 -} [
 

@@ -905,12 +914,12 @@ getCoreToDo dflags
     -- after this before anything else
         runWhen static_args (CoreDoPasses [ simpl_gently, CoreDoStaticArgs ]),
 
     -- after this before anything else
         runWhen static_args (CoreDoPasses [ simpl_gently, CoreDoStaticArgs ]),
 

-        -- initial simplify: mk specialiser happy: minimum effort please
-        simpl_gently,
-

         -- We run vectorisation here for now, but we might also try to run
         -- it later
         -- We run vectorisation here for now, but we might also try to run
         -- it later

-        runWhen vectorisation (CoreDoPasses [ CoreDoVectorisation, simpl_gently ]),
+        vectorisation,
+
+        -- initial simplify: mk specialiser happy: minimum effort please
+        simpl_gently,

 
         -- Specialisation is best done before full laziness
         -- so that overloaded functions have all their dictionary lambdas manifest
 
         -- Specialisation is best done before full laziness
         -- so that overloaded functions have all their dictionary lambdas manifest

@@ -1323,6 +1332,15 @@ dynamic_flags = [
          (IntSuffix $ \n -> upd $ \dfs -> dfs{ ctxtStkDepth = n })
          Supported
 
          (IntSuffix $ \n -> upd $ \dfs -> dfs{ ctxtStkDepth = n })
          Supported
 

+        ------ DPH flags ----------------------------------------------------
+
+  , Flag "fdph-seq"
+         (NoArg (upd (setDPHBackend DPHSeq)))
+         Supported
+  , Flag "fdph-par"
+         (NoArg (upd (setDPHBackend DPHPar)))
+         Supported
+

         ------ Compiler flags -----------------------------------------------
 
   , Flag "fasm"             (NoArg (setObjTarget HscAsm)) Supported
         ------ Compiler flags -----------------------------------------------
 
   , Flag "fasm"             (NoArg (setObjTarget HscAsm)) Supported

@@ -1711,6 +1729,11 @@ setDPHOpt dflags = setOptLevel 2 (dflags { maxSimplIterations  = 20
                    `dopt_set`   Opt_DictsCheap
                    `dopt_unset` Opt_MethodSharing
 
                    `dopt_set`   Opt_DictsCheap
                    `dopt_unset` Opt_MethodSharing
 

+data DPHBackend = DPHPar
+                | DPHSeq
+
+setDPHBackend :: DPHBackend -> DynFlags -> DynFlags
+setDPHBackend backend dflags = dflags { dphBackend = backend }

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

diff --git a/compiler/simplCore/SimplCore.lhs b/compiler/simplCore/SimplCore.lhs
index 75fbf19..86d3ec0 100644 (file)
--- a/compiler/simplCore/SimplCore.lhs
+++ b/compiler/simplCore/SimplCore.lhs
@@ -161,7 +161,7 @@ doCorePass CoreDoWorkerWrapper         = {-# SCC "WorkWrap" #-}      trBindsU ww
 doCorePass CoreDoSpecialising          = {-# SCC "Specialise" #-}    trBindsU specProgram
 doCorePass CoreDoSpecConstr           = {-# SCC "SpecConstr" #-}    trBindsU specConstrProgram
 doCorePass CoreDoGlomBinds            = trBinds glomBinds
 doCorePass CoreDoSpecialising          = {-# SCC "Specialise" #-}    trBindsU specProgram
 doCorePass CoreDoSpecConstr           = {-# SCC "SpecConstr" #-}    trBindsU specConstrProgram
 doCorePass CoreDoGlomBinds            = trBinds glomBinds

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

 doCorePass CoreDoPrintCore            = observe printCore
 doCorePass (CoreDoRuleCheck phase pat) = ruleCheck phase pat
 doCorePass CoreDoNothing              = observe (\ _ _ -> return ())
 doCorePass CoreDoPrintCore            = observe printCore
 doCorePass (CoreDoRuleCheck phase pat) = ruleCheck phase pat
 doCorePass CoreDoNothing              = observe (\ _ _ -> return ())

diff --git a/compiler/vectorise/VectMonad.hs b/compiler/vectorise/VectMonad.hs
index 1299683..e0063d5 100644 (file)
--- a/compiler/vectorise/VectMonad.hs
+++ b/compiler/vectorise/VectMonad.hs
@@ -37,7 +37,7 @@ module VectMonad (
 import VectBuiltIn
 
 import HscTypes
 import VectBuiltIn
 
 import HscTypes

-import Module        ( dphSeqPackageId )
+import Module           ( PackageId )

 import CoreSyn
 import TyCon
 import DataCon
 import CoreSyn
 import TyCon
 import DataCon

@@ -479,8 +479,8 @@ lookupFamInst tycon tys
                       (ppr $ mkTyConApp tycon tys)
        }
 
                       (ppr $ mkTyConApp tycon tys)
        }
 

-initV :: HscEnv -> ModGuts -> VectInfo -> VM a -> IO (Maybe (VectInfo, a))
-initV hsc_env guts info p
+initV :: PackageId -> HscEnv -> ModGuts -> VectInfo -> VM a -> IO (Maybe (VectInfo, a))
+initV pkg hsc_env guts info p

   = do
       Just r <- initDs hsc_env (mg_module guts)
                                (mg_rdr_env guts)
   = do
       Just r <- initDs hsc_env (mg_module guts)
                                (mg_rdr_env guts)

@@ -491,7 +491,7 @@ initV hsc_env guts info p
 
     go =
       do
 
     go =
       do

-        builtins       <- initBuiltins dphSeqPackageId
+        builtins       <- initBuiltins pkg

         builtin_vars   <- initBuiltinVars builtins
         builtin_tycons <- initBuiltinTyCons builtins
         let builtin_datacons = initBuiltinDataCons builtins
         builtin_vars   <- initBuiltinVars builtins
         builtin_tycons <- initBuiltinTyCons builtins
         let builtin_datacons = initBuiltinDataCons builtins

diff --git a/compiler/vectorise/Vectorise.hs b/compiler/vectorise/Vectorise.hs
index 46aa9a8..3b6cd83 100644 (file)
--- a/compiler/vectorise/Vectorise.hs
+++ b/compiler/vectorise/Vectorise.hs
@@ -10,6 +10,7 @@ import VectCore
 import DynFlags
 import HscTypes
 
 import DynFlags
 import HscTypes
 

+import Module               ( dphSeqPackageId, dphParPackageId )

 import CoreLint             ( showPass, endPass )
 import CoreSyn
 import CoreUtils
 import CoreLint             ( showPass, endPass )
 import CoreSyn
 import CoreUtils

@@ -36,19 +37,23 @@ import FastString
 import Control.Monad        ( liftM, liftM2, zipWithM )
 import Data.List            ( sortBy, unzip4 )
 
 import Control.Monad        ( liftM, liftM2, zipWithM )
 import Data.List            ( sortBy, unzip4 )
 

-vectorise :: HscEnv -> UniqSupply -> RuleBase -> ModGuts
+vectorise :: DPHBackend -> HscEnv -> UniqSupply -> RuleBase -> ModGuts

           -> IO (SimplCount, ModGuts)
           -> IO (SimplCount, ModGuts)

-vectorise hsc_env _ _ guts
+vectorise backend hsc_env _ _ guts

   = do
       showPass dflags "Vectorisation"
       eps <- hscEPS hsc_env
       let info = hptVectInfo hsc_env `plusVectInfo` eps_vect_info eps
   = do
       showPass dflags "Vectorisation"
       eps <- hscEPS hsc_env
       let info = hptVectInfo hsc_env `plusVectInfo` eps_vect_info eps

-      Just (info', guts') <- initV hsc_env guts info (vectModule guts)
+      Just (info', guts') <- initV (backendPackage backend) hsc_env guts info
+                                   (vectModule guts)

       endPass dflags "Vectorisation" Opt_D_dump_vect (mg_binds guts')
       return (zeroSimplCount dflags, guts' { mg_vect_info = info' })
   where
     dflags = hsc_dflags hsc_env
 
       endPass dflags "Vectorisation" Opt_D_dump_vect (mg_binds guts')
       return (zeroSimplCount dflags, guts' { mg_vect_info = info' })
   where
     dflags = hsc_dflags hsc_env
 

+    backendPackage DPHSeq  = dphSeqPackageId
+    backendPackage DPHPar  = dphParPackageId
+

 vectModule :: ModGuts -> VM ModGuts
 vectModule guts
   = do
 vectModule :: ModGuts -> VM ModGuts
 vectModule guts
   = do