diff options
| -rw-r--r-- | compiler/basicTypes/Module.lhs | 6 | ||||
| -rw-r--r-- | compiler/ghc.cabal.in | 2 | ||||
| -rw-r--r-- | compiler/ghci/Linker.lhs | 41 | ||||
| -rw-r--r-- | compiler/main/DynFlags.hs | 25 | ||||
| -rw-r--r-- | compiler/main/DynamicLoading.hs | 150 | ||||
| -rw-r--r-- | compiler/main/GhcPlugins.hs | 83 | ||||
| -rw-r--r-- | compiler/prelude/PrelNames.lhs | 18 | ||||
| -rw-r--r-- | compiler/simplCore/CoreMonad.lhs | 261 | ||||
| -rw-r--r-- | compiler/simplCore/SimplCore.lhs | 298 |
9 files changed, 669 insertions, 215 deletions
diff --git a/compiler/basicTypes/Module.lhs b/compiler/basicTypes/Module.lhs index 89b3eddfd7..6e566a23ad 100644 --- a/compiler/basicTypes/Module.lhs +++ b/compiler/basicTypes/Module.lhs @@ -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 diff --git a/compiler/ghc.cabal.in b/compiler/ghc.cabal.in index 841d85e6c0..2711c1b20e 100644 --- a/compiler/ghc.cabal.in +++ b/compiler/ghc.cabal.in @@ -314,6 +314,8 @@ Library Finder GHC GhcMake + GhcPlugins + DynamicLoading HeaderInfo HscMain HscStats diff --git a/compiler/ghci/Linker.lhs b/compiler/ghci/Linker.lhs index eaf452199e..ef349ebb10 100644 --- a/compiler/ghci/Linker.lhs +++ b/compiler/ghci/Linker.lhs @@ -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 diff --git a/compiler/main/DynFlags.hs b/compiler/main/DynFlags.hs index 5ce56f5016..167177703e 100644 --- a/compiler/main/DynFlags.hs +++ b/compiler/main/DynFlags.hs @@ -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" diff --git a/compiler/main/DynamicLoading.hs b/compiler/main/DynamicLoading.hs new file mode 100644 index 0000000000..5c7f6c7f0a --- /dev/null +++ b/compiler/main/DynamicLoading.hs @@ -0,0 +1,150 @@ +-- | 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 diff --git a/compiler/main/GhcPlugins.hs b/compiler/main/GhcPlugins.hs new file mode 100644 index 0000000000..0fc87f0fd0 --- /dev/null +++ b/compiler/main/GhcPlugins.hs @@ -0,0 +1,83 @@ +{-# 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 diff --git a/compiler/prelude/PrelNames.lhs b/compiler/prelude/PrelNames.lhs index d226cbebdc..4fd23ee712 100644 --- a/compiler/prelude/PrelNames.lhs +++ b/compiler/prelude/PrelNames.lhs @@ -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 diff --git a/compiler/simplCore/CoreMonad.lhs b/compiler/simplCore/CoreMonad.lhs index 6ddcff2b26..8e6ec5c870 100644 --- a/compiler/simplCore/CoreMonad.lhs +++ b/compiler/simplCore/CoreMonad.lhs @@ -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 - -- difference at all to performance if we do it here, - -- but maybe we save some unnecessary to-and-fro in - -- the simplifier. - - runWhen do_float_in CoreDoFloatInwards, - - simpl_phases, - - -- Phase 0: allow all Ids to be inlined now - -- This gets foldr inlined before strictness analysis - - -- At least 3 iterations because otherwise we land up with - -- huge dead expressions because of an infelicity in the - -- simpifier. - -- let k = BIG in foldr k z xs - -- ==> let k = BIG in letrec go = \xs -> ...(k x).... in go xs - -- ==> let k = BIG in letrec go = \xs -> ...(BIG x).... in go xs - -- Don't stop now! - simpl_phase 0 ["main"] (max max_iter 3), - - runWhen strictness (CoreDoPasses [ - CoreDoStrictness, - CoreDoWorkerWrapper, - CoreDoGlomBinds, - simpl_phase 0 ["post-worker-wrapper"] max_iter - ]), - - runWhen full_laziness $ - CoreDoFloatOutwards FloatOutSwitches { - floatOutLambdas = floatLamArgs dflags, - floatOutConstants = True, - floatOutPartialApplications = True }, - -- nofib/spectral/hartel/wang doubles in speed if you - -- do full laziness late in the day. It only happens - -- after fusion and other stuff, so the early pass doesn't - -- catch it. For the record, the redex is - -- f_el22 (f_el21 r_midblock) - - - runWhen cse CoreCSE, - -- We want CSE to follow the final full-laziness pass, because it may - -- succeed in commoning up things floated out by full laziness. - -- CSE used to rely on the no-shadowing invariant, but it doesn't any more - - runWhen do_float_in CoreDoFloatInwards, - - maybe_rule_check (Phase 0), - - -- Case-liberation for -O2. This should be after - -- strictness analysis and the simplification which follows it. - runWhen liberate_case (CoreDoPasses [ - CoreLiberateCase, - simpl_phase 0 ["post-liberate-case"] max_iter - ]), -- Run the simplifier after LiberateCase to vastly - -- reduce the possiblility of shadowing - -- Reason: see Note [Shadowing] in SpecConstr.lhs - - runWhen spec_constr CoreDoSpecConstr, - - maybe_rule_check (Phase 0), - - -- Final clean-up simplification: - simpl_phase 0 ["final"] max_iter - ] + , sm_eta_expand = False + , sm_case_case = False + }) -- The core-to-core pass ordering is derived from the DynFlags: runWhen :: Bool -> CoreToDo -> CoreToDo @@ -531,6 +360,7 @@ runMaybe :: Maybe a -> (a -> CoreToDo) -> CoreToDo runMaybe (Just x) f = f x runMaybe Nothing _ = CoreDoNothing + dumpSimplPhase :: DynFlags -> SimplifierMode -> Bool dumpSimplPhase dflags mode | Just spec_string <- shouldDumpSimplPhase dflags @@ -579,6 +409,47 @@ to switch off those rules until after floating. %************************************************************************ %* * + Types for Plugins +%* * +%************************************************************************ + +\begin{code} +-- | Command line options gathered from the -PModule.Name:stuff syntax are given to you as this type +type CommandLineOption = String + +-- | 'Plugin' is the core compiler plugin data type. Try to avoid +-- constructing one of these directly, and just modify some fields of +-- 'defaultPlugin' instead: this is to try and preserve source-code +-- compatability when we add fields to this. +-- +-- Nonetheless, this API is preliminary and highly likely to change in the future. +data Plugin = Plugin { + installCoreToDos :: [CommandLineOption] -> [CoreToDo] -> CoreM [CoreToDo] + -- ^ Modify the Core pipeline that will be used for compilation. + -- This is called as the Core pipeline is built for every module + -- being compiled, and plugins get the opportunity to modify + -- the pipeline in a nondeterministic order. + } + +-- | Default plugin: does nothing at all! For compatability reasons you should base all your +-- plugin definitions on this default value. +defaultPlugin :: Plugin +defaultPlugin = Plugin { + installCoreToDos = const return + } + +-- | A description of the plugin pass itself +type PluginPass = ModGuts -> CoreM ModGuts + +bindsOnlyPass :: ([CoreBind] -> CoreM [CoreBind]) -> ModGuts -> CoreM ModGuts +bindsOnlyPass pass guts + = do { binds' <- pass (mg_binds guts) + ; return (guts { mg_binds = binds' }) } +\end{code} + + +%************************************************************************ +%* * Counting and logging %* * %************************************************************************ @@ -955,7 +826,6 @@ liftIOWithCount what = liftIO what >>= (\(count, x) -> addSimplCount count >> re %************************************************************************ \begin{code} - getHscEnv :: CoreM HscEnv getHscEnv = read cr_hsc_env @@ -979,7 +849,6 @@ getOrigNameCache :: CoreM OrigNameCache getOrigNameCache = do nameCacheRef <- fmap hsc_NC getHscEnv liftIO $ fmap nsNames $ readIORef nameCacheRef - \end{code} diff --git a/compiler/simplCore/SimplCore.lhs b/compiler/simplCore/SimplCore.lhs index 59aba4b030..34ffacb208 100644 --- a/compiler/simplCore/SimplCore.lhs +++ b/compiler/simplCore/SimplCore.lhs @@ -8,7 +8,7 @@ module SimplCore ( core2core, simplifyExpr ) where #include "HsVersions.h" -import DynFlags ( DynFlags, DynFlag(..), dopt ) +import DynFlags import CoreSyn import CoreSubst import HscTypes @@ -29,7 +29,7 @@ import FloatIn ( floatInwards ) import FloatOut ( floatOutwards ) import FamInstEnv import Id -import BasicTypes +import BasicTypes ( CompilerPhase(..), isDefaultInlinePragma ) import VarSet import VarEnv import LiberateCase ( liberateCase ) @@ -45,6 +45,16 @@ import Util import UniqSupply ( UniqSupply, mkSplitUniqSupply, splitUniqSupply ) import Outputable import Control.Monad + +#ifdef GHCI +import Type ( mkTyConTy ) +import RdrName ( mkRdrQual ) +import OccName ( mkVarOcc ) +import PrelNames ( pluginTyConName ) +import DynamicLoading ( forceLoadTyCon, lookupRdrNameInModule, getValueSafely ) +import Module ( ModuleName ) +import Panic +#endif \end{code} %************************************************************************ @@ -57,9 +67,18 @@ import Control.Monad core2core :: HscEnv -> ModGuts -> IO ModGuts core2core hsc_env guts = do { us <- mkSplitUniqSupply 's' - ; (guts2, stats) <- runCoreM hsc_env hpt_rule_base us mod $ - doCorePasses (getCoreToDo dflags) guts - + -- make sure all plugins are loaded + + ; let builtin_passes = getCoreToDo dflags + ; + ; (guts2, stats) <- runCoreM hsc_env hpt_rule_base us mod $ + do { all_passes <- addPluginPasses dflags builtin_passes + ; runCorePasses all_passes guts } + +{-- + ; Err.dumpIfSet_dyn dflags Opt_D_dump_core_pipeline + "Plugin information" "" -- TODO FIXME: dump plugin info +--} ; Err.dumpIfSet_dyn dflags Opt_D_dump_simpl_stats "Grand total simplifier statistics" (pprSimplCount stats) @@ -75,16 +94,262 @@ core2core hsc_env guts -- consume the ModGuts to find the module) but somewhat ugly because mg_module may -- _theoretically_ be changed during the Core pipeline (it's part of ModGuts), which -- would mean our cached value would go out of date. +\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 + , sm_names = ["Gentle"] + , sm_rules = rules_on -- 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 + -- difference at all to performance if we do it here, + -- but maybe we save some unnecessary to-and-fro in + -- the simplifier. + + runWhen do_float_in CoreDoFloatInwards, + + simpl_phases, + + -- Phase 0: allow all Ids to be inlined now + -- This gets foldr inlined before strictness analysis + + -- At least 3 iterations because otherwise we land up with + -- huge dead expressions because of an infelicity in the + -- simpifier. + -- let k = BIG in foldr k z xs + -- ==> let k = BIG in letrec go = \xs -> ...(k x).... in go xs + -- ==> let k = BIG in letrec go = \xs -> ...(BIG x).... in go xs + -- Don't stop now! + simpl_phase 0 ["main"] (max max_iter 3), + + runWhen strictness (CoreDoPasses [ + CoreDoStrictness, + CoreDoWorkerWrapper, + CoreDoGlomBinds, + simpl_phase 0 ["post-worker-wrapper"] max_iter + ]), + + runWhen full_laziness $ + CoreDoFloatOutwards FloatOutSwitches { + floatOutLambdas = floatLamArgs dflags, + floatOutConstants = True, + floatOutPartialApplications = True }, + -- nofib/spectral/hartel/wang doubles in speed if you + -- do full laziness late in the day. It only happens + -- after fusion and other stuff, so the early pass doesn't + -- catch it. For the record, the redex is + -- f_el22 (f_el21 r_midblock) + + + runWhen cse CoreCSE, + -- We want CSE to follow the final full-laziness pass, because it may + -- succeed in commoning up things floated out by full laziness. + -- CSE used to rely on the no-shadowing invariant, but it doesn't any more + + runWhen do_float_in CoreDoFloatInwards, + + maybe_rule_check (Phase 0), + + -- Case-liberation for -O2. This should be after + -- strictness analysis and the simplification which follows it. + runWhen liberate_case (CoreDoPasses [ + CoreLiberateCase, + simpl_phase 0 ["post-liberate-case"] max_iter + ]), -- Run the simplifier after LiberateCase to vastly + -- reduce the possiblility of shadowing + -- Reason: see Note [Shadowing] in SpecConstr.lhs + + runWhen spec_constr CoreDoSpecConstr, + + maybe_rule_check (Phase 0), + + -- Final clean-up simplification: + simpl_phase 0 ["final"] max_iter + ] +\end{code} -type CorePass = CoreToDo +Loading plugins -doCorePasses :: [CorePass] -> ModGuts -> CoreM ModGuts -doCorePasses passes guts +\begin{code} +addPluginPasses :: DynFlags -> [CoreToDo] -> CoreM [CoreToDo] +#ifndef GHCI +addPluginPasses _ builtin_passes = return builtin_passes +#else +addPluginPasses dflags builtin_passes + = do { hsc_env <- getHscEnv + ; named_plugins <- liftIO (loadPlugins hsc_env) + ; foldM query_plug builtin_passes named_plugins } + where + query_plug todos (mod_nm, plug) + = installCoreToDos plug options todos + where + options = [ option | (opt_mod_nm, option) <- pluginModNameOpts dflags + , opt_mod_nm == mod_nm ] + +loadPlugins :: HscEnv -> IO [(ModuleName, Plugin)] +loadPlugins hsc_env + = do { let to_load = pluginModNames (hsc_dflags hsc_env) + ; plugins <- mapM (loadPlugin hsc_env) to_load + ; return $ to_load `zip` plugins } + +loadPlugin :: HscEnv -> ModuleName -> IO Plugin +loadPlugin hsc_env mod_name + = do { let plugin_rdr_name = mkRdrQual mod_name (mkVarOcc "plugin") + ; mb_name <- lookupRdrNameInModule hsc_env mod_name plugin_rdr_name + ; case mb_name of { + Nothing -> throwGhcException (CmdLineError $ showSDoc $ hsep + [ ptext (sLit "The module"), ppr mod_name + , ptext (sLit "did not export the plugin name") + , ppr plugin_rdr_name ]) ; + Just name -> + + do { plugin_tycon <- forceLoadTyCon hsc_env pluginTyConName + ; mb_plugin <- getValueSafely hsc_env name (mkTyConTy plugin_tycon) + ; case mb_plugin of + Nothing -> throwGhcException (CmdLineError $ showSDoc $ hsep + [ ptext (sLit "The value"), ppr name + , ptext (sLit "did not have the type") + , ppr pluginTyConName, ptext (sLit "as required")]) + Just plugin -> return plugin } } } +#endif +\end{code} + +%************************************************************************ +%* * + The CoreToDo interpreter +%* * +%************************************************************************ + +\begin{code} +runCorePasses :: [CoreToDo] -> ModGuts -> CoreM ModGuts +runCorePasses passes guts = foldM do_pass guts passes where do_pass guts CoreDoNothing = return guts - do_pass guts (CoreDoPasses ps) = doCorePasses ps guts + do_pass guts (CoreDoPasses ps) = runCorePasses ps guts do_pass guts pass = do { dflags <- getDynFlags ; liftIO $ showPass dflags pass @@ -92,7 +357,7 @@ doCorePasses passes guts ; liftIO $ endPass dflags pass (mg_binds guts') (mg_rules guts') ; return guts' } -doCorePass :: CorePass -> ModGuts -> CoreM ModGuts +doCorePass :: CoreToDo -> ModGuts -> CoreM ModGuts doCorePass pass@(CoreDoSimplify {}) = {-# SCC "Simplify" #-} simplifyPgm pass @@ -128,9 +393,14 @@ doCorePass CoreDoVectorisation = {-# SCC "Vectorise" #-} doCorePass CoreDoGlomBinds = doPassDM glomBinds doCorePass CoreDoPrintCore = observe printCore -doCorePass (CoreDoRuleCheck phase pat) = ruleCheck phase pat +doCorePass (CoreDoRuleCheck phase pat) = ruleCheckPass phase pat doCorePass CoreDoNothing = return -doCorePass (CoreDoPasses passes) = doCorePasses passes +doCorePass (CoreDoPasses passes) = runCorePasses passes + +#ifdef GHCI +doCorePass (CoreDoPluginPass _ pass) = {-# SCC "Plugin" #-} pass +#endif + doCorePass pass = pprPanic "doCorePass" (ppr pass) \end{code} @@ -144,8 +414,8 @@ doCorePass pass = pprPanic "doCorePass" (ppr pass) printCore :: a -> [CoreBind] -> IO () printCore _ binds = Err.dumpIfSet True "Print Core" (pprCoreBindings binds) -ruleCheck :: CompilerPhase -> String -> ModGuts -> CoreM ModGuts -ruleCheck current_phase pat guts = do +ruleCheckPass :: CompilerPhase -> String -> ModGuts -> CoreM ModGuts +ruleCheckPass current_phase pat guts = do rb <- getRuleBase dflags <- getDynFlags liftIO $ Err.showPass dflags "RuleCheck" |