Commit 85514ae1 authored by rl@cse.unsw.edu.au's avatar rl@cse.unsw.edu.au

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.
parent efe7a8d4
...@@ -23,6 +23,7 @@ module DynFlags ( ...@@ -23,6 +23,7 @@ module DynFlags (
Option(..), Option(..),
DynLibLoader(..), DynLibLoader(..),
fFlags, xFlags, fFlags, xFlags,
DPHBackend(..),
-- Configuration of the core-to-core and stg-to-stg phases -- Configuration of the core-to-core and stg-to-stg phases
CoreToDo(..), CoreToDo(..),
...@@ -310,6 +311,8 @@ data DynFlags = DynFlags { ...@@ -310,6 +311,8 @@ data DynFlags = DynFlags {
mainFunIs :: Maybe String, mainFunIs :: Maybe String,
ctxtStkDepth :: Int, -- Typechecker context stack depth ctxtStkDepth :: Int, -- Typechecker context stack depth
dphBackend :: DPHBackend,
thisPackage :: PackageId, thisPackage :: PackageId,
-- ways -- ways
...@@ -501,6 +504,8 @@ defaultDynFlags = ...@@ -501,6 +504,8 @@ defaultDynFlags =
mainFunIs = Nothing, mainFunIs = Nothing,
ctxtStkDepth = mAX_CONTEXT_REDUCTION_DEPTH, ctxtStkDepth = mAX_CONTEXT_REDUCTION_DEPTH,
dphBackend = DPHPar,
thisPackage = mainPackageId, thisPackage = mainPackageId,
objectDir = Nothing, objectDir = Nothing,
...@@ -807,7 +812,7 @@ data CoreToDo -- These are diff core-to-core passes, ...@@ -807,7 +812,7 @@ data CoreToDo -- These are diff core-to-core passes,
| CoreCSE | CoreCSE
| CoreDoRuleCheck Int{-CompilerPhase-} String -- Check for non-application of rules | CoreDoRuleCheck Int{-CompilerPhase-} String -- Check for non-application of rules
-- matching this string -- matching this string
| CoreDoVectorisation | CoreDoVectorisation DPHBackend
| CoreDoNothing -- Useful when building up | CoreDoNothing -- Useful when building up
| CoreDoPasses [CoreToDo] -- lists of these things | CoreDoPasses [CoreToDo] -- lists of these things
...@@ -848,7 +853,6 @@ getCoreToDo dflags ...@@ -848,7 +853,6 @@ getCoreToDo dflags
spec_constr = dopt Opt_SpecConstr dflags spec_constr = dopt Opt_SpecConstr dflags
liberate_case = dopt Opt_LiberateCase dflags liberate_case = dopt Opt_LiberateCase dflags
rule_check = ruleCheck dflags rule_check = ruleCheck dflags
vectorisation = dopt Opt_Vectorise dflags
static_args = dopt Opt_StaticArgumentTransformation dflags static_args = dopt Opt_StaticArgumentTransformation dflags
maybe_rule_check phase = runMaybe rule_check (CoreDoRuleCheck phase) maybe_rule_check phase = runMaybe rule_check (CoreDoRuleCheck phase)
...@@ -861,6 +865,11 @@ getCoreToDo dflags ...@@ -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. -- By default, we have 2 phases before phase 0.
-- Want to run with inline phase 2 after the specialiser to give -- Want to run with inline phase 2 after the specialiser to give
...@@ -895,7 +904,7 @@ getCoreToDo dflags ...@@ -895,7 +904,7 @@ getCoreToDo dflags
core_todo = core_todo =
if opt_level == 0 then if opt_level == 0 then
[runWhen vectorisation (CoreDoPasses [ simpl_gently, CoreDoVectorisation ]), [vectorisation,
simpl_phase 0 ["final"] max_iter] simpl_phase 0 ["final"] max_iter]
else {- opt_level >= 1 -} [ else {- opt_level >= 1 -} [
...@@ -905,12 +914,12 @@ getCoreToDo dflags ...@@ -905,12 +914,12 @@ getCoreToDo dflags
-- after this before anything else -- after this before anything else
runWhen static_args (CoreDoPasses [ simpl_gently, CoreDoStaticArgs ]), 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 -- We run vectorisation here for now, but we might also try to run
-- it later -- 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 -- Specialisation is best done before full laziness
-- so that overloaded functions have all their dictionary lambdas manifest -- so that overloaded functions have all their dictionary lambdas manifest
...@@ -1323,6 +1332,15 @@ dynamic_flags = [ ...@@ -1323,6 +1332,15 @@ dynamic_flags = [
(IntSuffix $ \n -> upd $ \dfs -> dfs{ ctxtStkDepth = n }) (IntSuffix $ \n -> upd $ \dfs -> dfs{ ctxtStkDepth = n })
Supported Supported
------ DPH flags ----------------------------------------------------
, Flag "fdph-seq"
(NoArg (upd (setDPHBackend DPHSeq)))
Supported
, Flag "fdph-par"
(NoArg (upd (setDPHBackend DPHPar)))
Supported
------ Compiler flags ----------------------------------------------- ------ Compiler flags -----------------------------------------------
, Flag "fasm" (NoArg (setObjTarget HscAsm)) Supported , Flag "fasm" (NoArg (setObjTarget HscAsm)) Supported
...@@ -1711,6 +1729,11 @@ setDPHOpt dflags = setOptLevel 2 (dflags { maxSimplIterations = 20 ...@@ -1711,6 +1729,11 @@ setDPHOpt dflags = setOptLevel 2 (dflags { maxSimplIterations = 20
`dopt_set` Opt_DictsCheap `dopt_set` Opt_DictsCheap
`dopt_unset` Opt_MethodSharing `dopt_unset` Opt_MethodSharing
data DPHBackend = DPHPar
| DPHSeq
setDPHBackend :: DPHBackend -> DynFlags -> DynFlags
setDPHBackend backend dflags = dflags { dphBackend = backend }
setMainIs :: String -> DynP () setMainIs :: String -> DynP ()
......
...@@ -161,7 +161,7 @@ doCorePass CoreDoWorkerWrapper = {-# SCC "WorkWrap" #-} trBindsU ww ...@@ -161,7 +161,7 @@ doCorePass CoreDoWorkerWrapper = {-# SCC "WorkWrap" #-} trBindsU ww
doCorePass CoreDoSpecialising = {-# SCC "Specialise" #-} trBindsU specProgram doCorePass CoreDoSpecialising = {-# SCC "Specialise" #-} trBindsU specProgram
doCorePass CoreDoSpecConstr = {-# SCC "SpecConstr" #-} trBindsU specConstrProgram doCorePass CoreDoSpecConstr = {-# SCC "SpecConstr" #-} trBindsU specConstrProgram
doCorePass CoreDoGlomBinds = trBinds glomBinds doCorePass CoreDoGlomBinds = trBinds glomBinds
doCorePass CoreDoVectorisation = {-# SCC "Vectorise" #-} vectorise doCorePass (CoreDoVectorisation be) = {-# SCC "Vectorise" #-} vectorise be
doCorePass CoreDoPrintCore = observe printCore doCorePass CoreDoPrintCore = observe printCore
doCorePass (CoreDoRuleCheck phase pat) = ruleCheck phase pat doCorePass (CoreDoRuleCheck phase pat) = ruleCheck phase pat
doCorePass CoreDoNothing = observe (\ _ _ -> return ()) doCorePass CoreDoNothing = observe (\ _ _ -> return ())
......
...@@ -37,7 +37,7 @@ module VectMonad ( ...@@ -37,7 +37,7 @@ module VectMonad (
import VectBuiltIn import VectBuiltIn
import HscTypes import HscTypes
import Module ( dphSeqPackageId ) import Module ( PackageId )
import CoreSyn import CoreSyn
import TyCon import TyCon
import DataCon import DataCon
...@@ -479,8 +479,8 @@ lookupFamInst tycon tys ...@@ -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 :: PackageId -> HscEnv -> ModGuts -> VectInfo -> VM a -> IO (Maybe (VectInfo, a))
initV hsc_env guts info p initV pkg hsc_env guts info p
= do = do
Just r <- initDs hsc_env (mg_module guts) Just r <- initDs hsc_env (mg_module guts)
(mg_rdr_env guts) (mg_rdr_env guts)
...@@ -491,7 +491,7 @@ initV hsc_env guts info p ...@@ -491,7 +491,7 @@ initV hsc_env guts info p
go = go =
do do
builtins <- initBuiltins dphSeqPackageId builtins <- initBuiltins pkg
builtin_vars <- initBuiltinVars builtins builtin_vars <- initBuiltinVars builtins
builtin_tycons <- initBuiltinTyCons builtins builtin_tycons <- initBuiltinTyCons builtins
let builtin_datacons = initBuiltinDataCons builtins let builtin_datacons = initBuiltinDataCons builtins
......
...@@ -10,6 +10,7 @@ import VectCore ...@@ -10,6 +10,7 @@ import VectCore
import DynFlags import DynFlags
import HscTypes import HscTypes
import Module ( dphSeqPackageId, dphParPackageId )
import CoreLint ( showPass, endPass ) import CoreLint ( showPass, endPass )
import CoreSyn import CoreSyn
import CoreUtils import CoreUtils
...@@ -36,19 +37,23 @@ import FastString ...@@ -36,19 +37,23 @@ import FastString
import Control.Monad ( liftM, liftM2, zipWithM ) import Control.Monad ( liftM, liftM2, zipWithM )
import Data.List ( sortBy, unzip4 ) 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 = do
showPass dflags "Vectorisation" showPass dflags "Vectorisation"
eps <- hscEPS hsc_env eps <- hscEPS hsc_env
let info = hptVectInfo hsc_env `plusVectInfo` eps_vect_info eps 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') endPass dflags "Vectorisation" Opt_D_dump_vect (mg_binds guts')
return (zeroSimplCount dflags, guts' { mg_vect_info = info' }) return (zeroSimplCount dflags, guts' { mg_vect_info = info' })
where where
dflags = hsc_dflags hsc_env dflags = hsc_dflags hsc_env
backendPackage DPHSeq = dphSeqPackageId
backendPackage DPHPar = dphParPackageId
vectModule :: ModGuts -> VM ModGuts vectModule :: ModGuts -> VM ModGuts
vectModule guts vectModule guts
= do = do
......
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment