From 85514ae1d86203212930c4953ae608b53aa9f452 Mon Sep 17 00:00:00 2001 From: Roman Leshchinskiy Date: Wed, 2 Jul 2008 02:22:02 +0000 Subject: [PATCH] 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. --- compiler/main/DynFlags.hs | 37 ++++++++++++++++++++++++++++++------- compiler/simplCore/SimplCore.lhs | 2 +- compiler/vectorise/VectMonad.hs | 8 ++++---- compiler/vectorise/Vectorise.hs | 11 ++++++++--- 4 files changed, 43 insertions(+), 15 deletions(-) diff --git a/compiler/main/DynFlags.hs b/compiler/main/DynFlags.hs index 931d384..637907f 100644 --- a/compiler/main/DynFlags.hs +++ b/compiler/main/DynFlags.hs @@ -23,6 +23,7 @@ module DynFlags ( Option(..), DynLibLoader(..), fFlags, xFlags, + DPHBackend(..), -- 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 + dphBackend :: DPHBackend, + thisPackage :: PackageId, -- ways @@ -501,6 +504,8 @@ defaultDynFlags = mainFunIs = Nothing, ctxtStkDepth = mAX_CONTEXT_REDUCTION_DEPTH, + dphBackend = DPHPar, + 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 - | CoreDoVectorisation + | CoreDoVectorisation DPHBackend | 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 - vectorisation = dopt Opt_Vectorise dflags 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 ] + 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 @@ -895,7 +904,7 @@ getCoreToDo dflags core_todo = if opt_level == 0 then - [runWhen vectorisation (CoreDoPasses [ simpl_gently, CoreDoVectorisation ]), + [vectorisation, 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 ]), - -- 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 - 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 @@ -1323,6 +1332,15 @@ dynamic_flags = [ (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 @@ -1711,6 +1729,11 @@ setDPHOpt dflags = setOptLevel 2 (dflags { maxSimplIterations = 20 `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 () diff --git a/compiler/simplCore/SimplCore.lhs b/compiler/simplCore/SimplCore.lhs index 75fbf19..86d3ec0 100644 --- 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 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 ()) diff --git a/compiler/vectorise/VectMonad.hs b/compiler/vectorise/VectMonad.hs index 1299683..e0063d5 100644 --- a/compiler/vectorise/VectMonad.hs +++ b/compiler/vectorise/VectMonad.hs @@ -37,7 +37,7 @@ module VectMonad ( import VectBuiltIn import HscTypes -import Module ( dphSeqPackageId ) +import Module ( PackageId ) import CoreSyn import TyCon import DataCon @@ -479,8 +479,8 @@ lookupFamInst 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) @@ -491,7 +491,7 @@ initV hsc_env guts info p go = do - builtins <- initBuiltins dphSeqPackageId + builtins <- initBuiltins pkg 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 --- a/compiler/vectorise/Vectorise.hs +++ b/compiler/vectorise/Vectorise.hs @@ -10,6 +10,7 @@ import VectCore import DynFlags import HscTypes +import Module ( dphSeqPackageId, dphParPackageId ) 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 ) -vectorise :: HscEnv -> UniqSupply -> RuleBase -> ModGuts +vectorise :: DPHBackend -> HscEnv -> UniqSupply -> RuleBase -> 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 - 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 + backendPackage DPHSeq = dphSeqPackageId + backendPackage DPHPar = dphParPackageId + vectModule :: ModGuts -> VM ModGuts vectModule guts = do -- 1.7.10.4