Commit 592def09 authored by Simon Peyton Jones's avatar Simon Peyton Jones

Add dynamically-linked plugins (see Trac #3843)

This patch was originally developed by Max Bolingbroke, and worked on
further by Austin Seipp.  It allows you to write a Core-to-Core pass
and have it dynamically linked into an otherwise-unmodified GHC, and
run at a place you specify in the Core optimisation pipeline.

Main components:
  - CoreMonad: new types Plugin, PluginPass
               plus a new constructor CoreDoPluginPass in CoreToDo

  - SimplCore: stuff to dynamically load any plugins, splice
    them into the core-to-core pipeline, and invoke them

  - Move "getCoreToDo :: DynFlags -> [CoreToDo]"
      which constructs the main core-to-core pipeline
      from CoreMonad to SimplCore
    SimplCore is the driver for the optimisation pipeline, and it
    makes more sense to have the pipeline construction in the driver
    not in the infrastructure module.

  - New module DynamicLoading: invoked by SimplCore to load any plugins
    Some consequential changes in Linker.

  - New module GhcPlugins: this should be imported by plugin modules; it
    it not used by GHC itself.
parent be4726ed
......@@ -39,7 +39,8 @@ module Module
dphSeqPackageId,
dphParPackageId,
mainPackageId,
thisGhcPackageId,
-- * The Module type
Module,
modulePackageId, moduleName,
......@@ -342,7 +343,7 @@ packageIdString = unpackFS . packageIdFS
integerPackageId, primPackageId,
basePackageId, rtsPackageId,
thPackageId, dphSeqPackageId, dphParPackageId,
mainPackageId :: PackageId
mainPackageId, thisGhcPackageId :: PackageId
primPackageId = fsToPackageId (fsLit "ghc-prim")
integerPackageId = fsToPackageId (fsLit cIntegerLibrary)
basePackageId = fsToPackageId (fsLit "base")
......@@ -350,6 +351,7 @@ rtsPackageId = fsToPackageId (fsLit "rts")
thPackageId = fsToPackageId (fsLit "template-haskell")
dphSeqPackageId = fsToPackageId (fsLit "dph-seq")
dphParPackageId = fsToPackageId (fsLit "dph-par")
thisGhcPackageId = fsToPackageId (fsLit ("ghc-" ++ cProjectVersion))
-- | This is the package Id for the current program. It is the default
-- package Id if you don't specify a package name. We don't add this prefix
......
......@@ -314,6 +314,8 @@ Library
Finder
GHC
GhcMake
GhcPlugins
DynamicLoading
HeaderInfo
HscMain
HscStats
......
......@@ -15,8 +15,8 @@ module Linker ( HValue, getHValue, showLinkerState,
linkExpr, unload, withExtendedLinkEnv,
extendLinkEnv, deleteFromLinkEnv,
extendLoadedPkgs,
linkPackages,initDynLinker,
dataConInfoPtrToName
linkPackages,initDynLinker,linkModule,
dataConInfoPtrToName, lessUnsafeCoerce
) where
#include "HsVersions.h"
......@@ -55,6 +55,8 @@ import Constants
import FastString
import Config
import GHC.Exts (unsafeCoerce#)
-- Standard libraries
import Control.Monad
......@@ -264,6 +266,7 @@ dataConInfoPtrToName x = do
-- Throws a 'ProgramError' if loading fails or the name cannot be found.
getHValue :: HscEnv -> Name -> IO HValue
getHValue hsc_env name = do
initDynLinker (hsc_dflags hsc_env)
pls <- modifyMVar v_PersistentLinkerState $ \pls -> do
if (isExternalName name) then do
(pls', ok) <- linkDependencies hsc_env pls noSrcSpan [nameModule name]
......@@ -277,6 +280,7 @@ linkDependencies :: HscEnv -> PersistentLinkerState
-> SrcSpan -> [Module]
-> IO (PersistentLinkerState, SuccessFlag)
linkDependencies hsc_env pls span needed_mods = do
-- initDynLinker (hsc_dflags hsc_env)
let hpt = hsc_HPT hsc_env
dflags = hsc_dflags hsc_env
-- The interpreter and dynamic linker can only handle object code built
......@@ -696,6 +700,38 @@ getLinkDeps hsc_env hpt pls maybe_normal_osuf span mods
adjust_ul _ _ = panic "adjust_ul"
\end{code}
%************************************************************************
%* *
Loading a single module
%* *
%************************************************************************
\begin{code}
-- | Link a single module
linkModule :: HscEnv -> Module -> IO ()
linkModule hsc_env mod = do
initDynLinker (hsc_dflags hsc_env)
modifyMVar v_PersistentLinkerState $ \pls -> do
(pls', ok) <- linkDependencies hsc_env pls noSrcSpan [mod]
if (failed ok) then ghcError (ProgramError "could not link module")
else return (pls',())
-- | Coerce a value as usual, but:
--
-- 1) Evaluate it immediately to get a segfault early if the coercion was wrong
--
-- 2) Wrap it in some debug messages at verbosity 3 or higher so we can see what happened
-- if it /does/ segfault
lessUnsafeCoerce :: DynFlags -> String -> a -> IO b
lessUnsafeCoerce dflags context what = do
debugTraceMsg dflags 3 $ (ptext $ sLit "Coercing a value in") <+> (text context) <> (ptext $ sLit "...")
output <- evaluate (unsafeCoerce# what)
debugTraceMsg dflags 3 $ ptext $ sLit "Successfully evaluated coercion"
return output
\end{code}
%************************************************************************
%* *
......@@ -997,6 +1033,7 @@ linkPackages :: DynFlags -> [PackageId] -> IO ()
linkPackages dflags new_pkgs = do
-- It's probably not safe to try to load packages concurrently, so we take
-- a lock.
initDynLinker dflags
modifyMVar_ v_PersistentLinkerState $ \pls -> do
linkPackages' dflags new_pkgs pls
......
......@@ -163,6 +163,7 @@ data DynFlag
| Opt_D_dump_occur_anal
| Opt_D_dump_parsed
| Opt_D_dump_rn
| Opt_D_dump_core_pipeline -- TODO FIXME: dump after simplifier stats
| Opt_D_dump_simpl
| Opt_D_dump_simpl_iterations
| Opt_D_dump_simpl_phases
......@@ -469,6 +470,10 @@ data DynFlags = DynFlags {
hpcDir :: String, -- ^ Path to store the .mix files
-- Plugins
pluginModNames :: [ModuleName],
pluginModNameOpts :: [(ModuleName,String)],
settings :: Settings,
-- For ghc -M
......@@ -788,6 +793,9 @@ defaultDynFlags mySettings =
hcSuf = phaseInputExt HCc,
hiSuf = "hi",
pluginModNames = [],
pluginModNameOpts = [],
outputFile = Nothing,
outputHi = Nothing,
dynLibLoader = SystemDependent,
......@@ -979,6 +987,16 @@ setHcSuf f d = d{ hcSuf = f}
setOutputFile f d = d{ outputFile = f}
setOutputHi f d = d{ outputHi = f}
addPluginModuleName :: String -> DynFlags -> DynFlags
addPluginModuleName name d = d { pluginModNames = (mkModuleName name) : (pluginModNames d) }
addPluginModuleNameOption :: String -> DynFlags -> DynFlags
addPluginModuleNameOption optflag d = d { pluginModNameOpts = (mkModuleName m, option) : (pluginModNameOpts d) }
where (m, rest) = break (== ':') optflag
option = case rest of
[] -> "" -- should probably signal an error
(_:plug_opt) -> plug_opt -- ignore the ':' from break
parseDynLibLoaderMode f d =
case splitAt 8 f of
("deploy", "") -> d{ dynLibLoader = Deployable }
......@@ -1319,6 +1337,7 @@ dynamic_flags = [
, Flag "ddump-occur-anal" (setDumpFlag Opt_D_dump_occur_anal)
, Flag "ddump-parsed" (setDumpFlag Opt_D_dump_parsed)
, Flag "ddump-rn" (setDumpFlag Opt_D_dump_rn)
, Flag "ddump-core-pipeline" (setDumpFlag Opt_D_dump_core_pipeline)
, Flag "ddump-simpl" (setDumpFlag Opt_D_dump_simpl)
, Flag "ddump-simpl-iterations" (setDumpFlag Opt_D_dump_simpl_iterations)
, Flag "ddump-simpl-phases" (OptPrefix setDumpSimplPhases)
......@@ -1377,7 +1396,11 @@ dynamic_flags = [
, Flag "Wnot" (NoArg (do { mapM_ unSetDynFlag minusWallOpts
; deprecate "Use -w instead" }))
, Flag "w" (NoArg (mapM_ unSetDynFlag minuswRemovesOpts))
------ Plugin flags ------------------------------------------------
, Flag "fplugin" (hasArg addPluginModuleName)
, Flag "fplugin-opt" (hasArg addPluginModuleNameOption)
------ Optimisation flags ------------------------------------------
, Flag "O" (noArgM (setOptLevel 1))
, Flag "Onot" (noArgM (\dflags -> do deprecate "Use -O0 instead"
......
-- | Dynamically lookup up values from modules and loading them.
module DynamicLoading (
#ifdef GHCI
-- * Force loading information
forceLoadModuleInterfaces,
forceLoadNameModuleInterface,
forceLoadTyCon,
-- * Finding names
lookupRdrNameInModule,
-- * Loading values
getValueSafely,
lessUnsafeCoerce
#endif
) where
#ifdef GHCI
import Linker ( linkModule, getHValue, lessUnsafeCoerce )
import OccName ( occNameSpace )
import Name ( nameOccName )
import SrcLoc ( noSrcSpan )
import Finder ( findImportedModule, cannotFindModule )
import DriverPhases ( HscSource(HsSrcFile) )
import TcRnDriver ( getModuleExports )
import TcRnMonad ( initTc, initIfaceTcRn )
import LoadIface ( loadUserInterface )
import RdrName ( RdrName, Provenance(..), ImportSpec(..), ImpDeclSpec(..), ImpItemSpec(..),
mkGlobalRdrEnv, lookupGRE_RdrName, gre_name, rdrNameSpace )
import RnNames ( gresFromAvails )
import PrelNames ( iNTERACTIVE )
import HscTypes ( HscEnv(..), FindResult(..), lookupTypeHscEnv )
import TypeRep ( TyThing(..), pprTyThingCategory )
import Type ( Type, eqType )
import TyCon ( TyCon )
import Name ( Name, nameModule_maybe )
import Id ( idType )
import Module ( Module, ModuleName )
import Panic ( GhcException(..), throwGhcException )
import FastString
import Outputable
import Data.Maybe ( mapMaybe )
-- | Force the interfaces for the given modules to be loaded. The 'SDoc' parameter is used
-- for debugging (@-ddump-if-trace@) only: it is shown as the reason why the module is being loaded.
forceLoadModuleInterfaces :: HscEnv -> SDoc -> [Module] -> IO ()
forceLoadModuleInterfaces hsc_env doc modules
= (initTc hsc_env HsSrcFile False iNTERACTIVE $ initIfaceTcRn $ mapM_ (loadUserInterface False doc) modules) >> return ()
-- | Force the interface for the module containing the name to be loaded. The 'SDoc' parameter is used
-- for debugging (@-ddump-if-trace@) only: it is shown as the reason why the module is being loaded.
forceLoadNameModuleInterface :: HscEnv -> SDoc -> Name -> IO ()
forceLoadNameModuleInterface hsc_env reason name = do
let name_modules = mapMaybe nameModule_maybe [name]
forceLoadModuleInterfaces hsc_env reason name_modules
-- | Load the 'TyCon' associated with the given name, come hell or high water. Fails if:
--
-- * The interface could not be loaded
-- * The name is not that of a 'TyCon'
-- * The name did not exist in the loaded module
forceLoadTyCon :: HscEnv -> Name -> IO TyCon
forceLoadTyCon hsc_env con_name = do
forceLoadNameModuleInterface hsc_env (ptext (sLit "contains a name used in an invocation of loadTyConTy")) con_name
mb_con_thing <- lookupTypeHscEnv hsc_env con_name
case mb_con_thing of
Nothing -> throwCmdLineErrorS $ missingTyThingError con_name
Just (ATyCon tycon) -> return tycon
Just con_thing -> throwCmdLineErrorS $ wrongTyThingError con_name con_thing
-- | Loads the value corresponding to a 'Name' if that value has the given 'Type'. This only provides limited safety
-- in that it is up to the user to ensure that that type corresponds to the type you try to use the return value at!
--
-- If the value found was not of the correct type, returns @Nothing@. Any other condition results in an exception:
--
-- * If we could not load the names module
-- * If the thing being loaded is not a value
-- * If the Name does not exist in the module
-- * If the link failed
getValueSafely :: HscEnv -> Name -> Type -> IO (Maybe a)
getValueSafely hsc_env val_name expected_type = do
forceLoadNameModuleInterface hsc_env (ptext (sLit "contains a name used in an invocation of getValueSafely")) val_name
-- Now look up the names for the value and type constructor in the type environment
mb_val_thing <- lookupTypeHscEnv hsc_env val_name
case mb_val_thing of
Nothing -> throwCmdLineErrorS $ missingTyThingError val_name
Just (AnId id) -> do
-- Check the value type in the interface against the type recovered from the type constructor
-- before finally casting the value to the type we assume corresponds to that constructor
if expected_type `eqType` idType id
then do
-- Link in the module that contains the value, if it has such a module
case nameModule_maybe val_name of
Just mod -> do linkModule hsc_env mod
return ()
Nothing -> return ()
-- Find the value that we just linked in and cast it given that we have proved it's type
hval <- getHValue hsc_env val_name
value <- lessUnsafeCoerce (hsc_dflags hsc_env) "getValueSafely" hval
return $ Just value
else return Nothing
Just val_thing -> throwCmdLineErrorS $ wrongTyThingError val_name val_thing
-- | Finds the 'Name' corresponding to the given 'RdrName' in the context of the 'ModuleName'. Returns @Nothing@ if no
-- such 'Name' could be found. Any other condition results in an exception:
--
-- * If the module could not be found
-- * If we could not determine the imports of the module
lookupRdrNameInModule :: HscEnv -> ModuleName -> RdrName -> IO (Maybe Name)
lookupRdrNameInModule hsc_env mod_name rdr_name = do
-- First find the package the module resides in by searching exposed packages and home modules
found_module <- findImportedModule hsc_env mod_name Nothing
case found_module of
Found _ mod -> do
-- Find the exports of the module
(_, mb_avail_info) <- getModuleExports hsc_env mod
case mb_avail_info of
Just avail_info -> do
-- Try and find the required name in the exports
let decl_spec = ImpDeclSpec { is_mod = mod_name, is_as = mod_name, is_qual = False, is_dloc = noSrcSpan }
provenance = Imported [ImpSpec decl_spec ImpAll]
env = mkGlobalRdrEnv (gresFromAvails provenance avail_info)
case [name | gre <- lookupGRE_RdrName rdr_name env, let name = gre_name gre, rdrNameSpace rdr_name == occNameSpace (nameOccName name)] of
[name] -> return (Just name)
[] -> return Nothing
_ -> panic "lookupRdrNameInModule"
Nothing -> throwCmdLineErrorS $ hsep [ptext (sLit "Could not determine the exports of the module"), ppr mod_name]
err -> throwCmdLineErrorS $ cannotFindModule dflags mod_name err
where
dflags = hsc_dflags hsc_env
wrongTyThingError :: Name -> TyThing -> SDoc
wrongTyThingError name got_thing = hsep [ptext (sLit "The name"), ppr name, ptext (sLit "is not that of a value but rather a"), pprTyThingCategory got_thing]
missingTyThingError :: Name -> SDoc
missingTyThingError name = hsep [ptext (sLit "The name"), ppr name, ptext (sLit "is not in the type environment: are you sure it exists?")]
throwCmdLineErrorS :: SDoc -> IO a
throwCmdLineErrorS = throwCmdLineError . showSDoc
throwCmdLineError :: String -> IO a
throwCmdLineError = throwGhcException . CmdLineError
#endif
{-# OPTIONS_GHC -fno-warn-duplicate-exports #-}
-- | This module is not used by GHC itself. Rather, it exports all of
-- the functions and types you are likely to need when writing a
-- plugin for GHC. So authors of plugins can probably get away simply
-- with saying "import GhcPlugins".
--
-- Particularly interesting modules for plugin writers include
-- "CoreSyn" and "CoreMonad".
module GhcPlugins(
module CoreMonad,
module RdrName, module OccName, module Name, module Var, module Id, module IdInfo,
module CoreSyn, module Literal, module DataCon,
module CoreUtils, module MkCore, module CoreFVs, module CoreSubst,
module Rules, module Annotations,
module DynFlags, module Packages,
module Module, module Type, module TyCon, module Coercion,
module TysWiredIn, module HscTypes, module BasicTypes,
module VarSet, module VarEnv, module NameSet, module NameEnv,
module UniqSet, module UniqFM, module FiniteMap,
module Util, module Serialized, module SrcLoc, module Outputable,
module UniqSupply, module Unique, module FastString, module FastTypes
) where
-- Plugin stuff itself
import CoreMonad
-- Variable naming
import RdrName
import OccName hiding ( varName {- conflicts with Var.varName -} )
import Name hiding ( varName {- reexport from OccName, conflicts with Var.varName -} )
import Var
import Id hiding ( lazySetIdInfo, setIdExported, setIdNotExported {- all three conflict with Var -} )
import IdInfo
-- Core
import CoreSyn
import Literal
import DataCon
import CoreUtils
import MkCore
import CoreFVs
import CoreSubst
-- Core "extras"
import Rules
import Annotations
-- Pipeline-related stuff
import DynFlags
import Packages
-- Important GHC types
import Module
import Type hiding {- conflict with CoreSubst -}
( substTy, extendTvSubst, extendTvSubstList, isInScope )
import Coercion hiding {- conflict with CoreSubst -}
( substTy, extendTvSubst, substCo, substTyVarBndr, lookupTyVar )
import TyCon
import TysWiredIn
import HscTypes
import BasicTypes hiding ( Version {- conflicts with Packages.Version -} )
-- Collections and maps
import VarSet
import VarEnv
import NameSet
import NameEnv
import UniqSet
import UniqFM
-- Conflicts with UniqFM:
--import LazyUniqFM
import FiniteMap
-- Common utilities
import Util
import Serialized
import SrcLoc
import Outputable
import UniqSupply
import Unique ( Unique, Uniquable(..) )
import FastString
import FastTypes
......@@ -219,6 +219,9 @@ basicKnownKeyNames
-- The Either type
, eitherTyConName, leftDataConName, rightDataConName
-- Plugins
, pluginTyConName
-- dotnet interop
, objectTyConName, marshalObjectName, unmarshalObjectName
, marshalStringName, unmarshalStringName, checkDotnetResName
......@@ -371,6 +374,12 @@ mkBaseModule m = mkModule basePackageId (mkModuleNameFS m)
mkBaseModule_ :: ModuleName -> Module
mkBaseModule_ m = mkModule basePackageId m
mkThisGhcModule :: FastString -> Module
mkThisGhcModule m = mkModule thisGhcPackageId (mkModuleNameFS m)
mkThisGhcModule_ :: ModuleName -> Module
mkThisGhcModule_ m = mkModule thisGhcPackageId m
mkMainModule :: FastString -> Module
mkMainModule m = mkModule mainPackageId (mkModuleNameFS m)
......@@ -973,6 +982,12 @@ marshalObjectName = varQual dOTNET (fsLit "marshalObject") marshalObjectIdKey
marshalStringName = varQual dOTNET (fsLit "marshalString") marshalStringIdKey
unmarshalStringName = varQual dOTNET (fsLit "unmarshalString") unmarshalStringIdKey
checkDotnetResName = varQual dOTNET (fsLit "checkResult") checkDotnetResNameIdKey
-- plugins
cORE_MONAD :: Module
cORE_MONAD = mkThisGhcModule (fsLit "CoreMonad")
pluginTyConName :: Name
pluginTyConName = tcQual cORE_MONAD (fsLit "Plugin") pluginTyConKey
\end{code}
%************************************************************************
......@@ -1193,6 +1208,9 @@ csel1CoercionTyConKey = mkPreludeTyConUnique 99
csel2CoercionTyConKey = mkPreludeTyConUnique 100
cselRCoercionTyConKey = mkPreludeTyConUnique 101
pluginTyConKey :: Unique
pluginTyConKey = mkPreludeTyConUnique 102
unknownTyConKey, unknown1TyConKey, unknown2TyConKey, unknown3TyConKey,
opaqueTyConKey :: Unique
unknownTyConKey = mkPreludeTyConUnique 129
......
......@@ -8,10 +8,16 @@
module CoreMonad (
-- * Configuration of the core-to-core passes
CoreToDo(..),
CoreToDo(..), runWhen, runMaybe,
SimplifierMode(..),
FloatOutSwitches(..),
getCoreToDo, dumpSimplPhase,
dumpSimplPhase,
defaultGentleSimplToDo,
-- * Plugins
PluginPass, Plugin(..), CommandLineOption,
defaultPlugin, bindsOnlyPass,
-- * Counting
SimplCount, doSimplTick, doFreeSimplTick, simplCountN,
......@@ -198,6 +204,7 @@ showLintWarnings _ = True
%************************************************************************
\begin{code}
data CoreToDo -- These are diff core-to-core passes,
-- which may be invoked in any order,
-- as many times as you like.
......@@ -205,7 +212,7 @@ data CoreToDo -- These are diff core-to-core passes,
= CoreDoSimplify -- The core-to-core simplifier.
Int -- Max iterations
SimplifierMode
| CoreDoPluginPass String PluginPass
| CoreDoFloatInwards
| CoreDoFloatOutwards FloatOutSwitches
| CoreLiberateCase
......@@ -229,8 +236,12 @@ data CoreToDo -- These are diff core-to-core passes,
| CoreTidy
| CorePrep
\end{code}
\begin{code}
coreDumpFlag :: CoreToDo -> Maybe DynFlag
coreDumpFlag (CoreDoSimplify {}) = Just Opt_D_dump_simpl_phases
coreDumpFlag (CoreDoPluginPass {}) = Just Opt_D_dump_core_pipeline
coreDumpFlag CoreDoFloatInwards = Just Opt_D_verbose_core2core
coreDumpFlag (CoreDoFloatOutwards {}) = Just Opt_D_verbose_core2core
coreDumpFlag CoreLiberateCase = Just Opt_D_verbose_core2core
......@@ -255,6 +266,7 @@ instance Outputable CoreToDo where
ppr (CoreDoSimplify n md) = ptext (sLit "Simplifier")
<+> ppr md
<+> ptext (sLit "max-iterations=") <> int n
ppr (CoreDoPluginPass s _) = ptext (sLit "Core plugin: ") <+> text s
ppr CoreDoFloatInwards = ptext (sLit "Float inwards")
ppr (CoreDoFloatOutwards f) = ptext (sLit "Float out") <> parens (ppr f)
ppr CoreLiberateCase = ptext (sLit "Liberate case")
......@@ -327,200 +339,17 @@ pprFloatOutSwitches sw
[ ptext (sLit "Lam =") <+> ppr (floatOutLambdas sw)
, ptext (sLit "Consts =") <+> ppr (floatOutConstants sw)
, ptext (sLit "PAPs =") <+> ppr (floatOutPartialApplications sw) ])
\end{code}
%************************************************************************
%* *
Generating the main optimisation pipeline
%* *
%************************************************************************
\begin{code}
getCoreToDo :: DynFlags -> [CoreToDo]
getCoreToDo dflags
= core_todo
where
opt_level = optLevel dflags
phases = simplPhases dflags
max_iter = maxSimplIterations dflags
rule_check = ruleCheck dflags
strictness = dopt Opt_Strictness dflags
full_laziness = dopt Opt_FullLaziness dflags
do_specialise = dopt Opt_Specialise dflags
do_float_in = dopt Opt_FloatIn dflags
cse = dopt Opt_CSE dflags
spec_constr = dopt Opt_SpecConstr dflags
liberate_case = dopt Opt_LiberateCase dflags
static_args = dopt Opt_StaticArgumentTransformation dflags
rules_on = dopt Opt_EnableRewriteRules dflags
eta_expand_on = dopt Opt_DoLambdaEtaExpansion dflags
maybe_rule_check phase = runMaybe rule_check (CoreDoRuleCheck phase)
maybe_strictness_before phase
= runWhen (phase `elem` strictnessBefore dflags) CoreDoStrictness
base_mode = SimplMode { sm_phase = panic "base_mode"
, sm_names = []
, sm_rules = rules_on
, sm_eta_expand = eta_expand_on
, sm_inline = True
, sm_case_case = True }
simpl_phase phase names iter
= CoreDoPasses
$ [ maybe_strictness_before phase
, CoreDoSimplify iter
(base_mode { sm_phase = Phase phase
, sm_names = names })
, maybe_rule_check (Phase phase) ]
-- Vectorisation can introduce a fair few common sub expressions involving
-- DPH primitives. For example, see the Reverse test from dph-examples.
-- We need to eliminate these common sub expressions before their definitions
-- are inlined in phase 2. The CSE introduces lots of v1 = v2 bindings,
-- so we also run simpl_gently to inline them.
++ (if dopt Opt_Vectorise dflags && phase == 3
then [CoreCSE, simpl_gently]
else [])
vectorisation
= runWhen (dopt Opt_Vectorise dflags) $
CoreDoPasses [ simpl_gently, CoreDoVectorisation ]
-- By default, we have 2 phases before phase 0.
-- Want to run with inline phase 2 after the specialiser to give
-- maximum chance for fusion to work before we inline build/augment
-- in phase 1. This made a difference in 'ansi' where an
-- overloaded function wasn't inlined till too late.
-- Need phase 1 so that build/augment get
-- inlined. I found that spectral/hartel/genfft lost some useful
-- strictness in the function sumcode' if augment is not inlined
-- before strictness analysis runs
simpl_phases = CoreDoPasses [ simpl_phase phase ["main"] max_iter
| phase <- [phases, phases-1 .. 1] ]
-- initial simplify: mk specialiser happy: minimum effort please
simpl_gently = CoreDoSimplify max_iter
(base_mode { sm_phase = InitialPhase
-- | A reasonably gentle simplification pass for doing "obvious" simplifications
defaultGentleSimplToDo :: CoreToDo
defaultGentleSimplToDo = CoreDoSimplify 4 -- 4 is the default maxSimpleIterations
(SimplMode { sm_phase = InitialPhase
, sm_names = ["Gentle"]
, sm_rules = rules_on -- Note [RULEs enabled in SimplGently]
, sm_rules = True -- Note [RULEs enabled in SimplGently]
, sm_inline = False
, sm_case_case = False })
-- Don't do case-of-case transformations.
-- This makes full laziness work better
core_todo =
if opt_level == 0 then
[vectorisation,
simpl_phase 0 ["final"] max_iter]
else {- opt_level >= 1 -} [
-- We want to do the static argument transform before full laziness as it
-- may expose extra opportunities to float things outwards. However, to fix
-- up the output of the transformation we need at do at least one simplify
-- after this before anything else
runWhen static_args (CoreDoPasses [ simpl_gently, CoreDoStaticArgs ]),
-- We run vectorisation here for now, but we might also try to run
-- it later
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
runWhen do_specialise CoreDoSpecialising,
runWhen full_laziness $
CoreDoFloatOutwards FloatOutSwitches {
floatOutLambdas = Just 0,
floatOutConstants = True,
floatOutPartialApplications = False },
-- Was: gentleFloatOutSwitches
--
-- I have no idea why, but not floating constants to
-- top level is very bad in some cases.
--
-- Notably: p_ident in spectral/rewrite
-- Changing from "gentle" to "constantsOnly"
-- improved rewrite's allocation by 19%, and
-- made 0.0% difference to any other nofib
-- benchmark
--
-- Not doing floatOutPartialApplications yet, we'll do
-- that later on when we've had a chance to get more
-- accurate arity information. In fact it makes no