Skip to content

Commit

Permalink
Some change to reduce cpp usage in the Main file.
Browse files Browse the repository at this point in the history 
- Made separate modules for each ghc version in the
  hopes that maintaining them would become easier
  than the many nested if, else we have in cpp right now.
  • Loading branch information
@pranaysashank
pranaysashank committed Aug 27, 2022
1 parent 3c6535a commit 3e986e1
Show file tree
Hide file tree
Showing 10 changed files with 1,009 additions and 273 deletions.
25 changes: 25 additions & 0 deletions fusion-plugin.cabal
View file
Original file line number Diff line number Diff line change
Expand Up @@ -43,6 +43,31 @@ source-repository head

library
exposed-modules: Fusion.Plugin
other-modules:
Fusion.Plugin.Ghc
if impl(ghc >= 9.5.0)
other-modules:
Fusion.Plugin.GhcHead
elif impl(ghc >= 9.4.0)
other-modules:
Fusion.Plugin.Ghc940
elif impl(ghc >= 9.3.0)
other-modules:
Fusion.Plugin.Ghc930
elif impl(ghc >= 9.2.2)
other-modules:
Fusion.Plugin.Ghc922
elif impl(ghc >= 9.2.0)
other-modules:
Fusion.Plugin.Ghc920
elif impl(ghc >= 9.0.0)
other-modules:
Fusion.Plugin.Ghc900
else
if impl(ghc >= 8.6.0)
other-modules:
Fusion.Plugin.Ghc860

build-depends: base >= 4.0 && < 5.0
, containers >= 0.5.6.2 && < 0.7
, directory >= 1.2.2.0 && < 1.4
Expand Down
284 changes: 11 additions & 273 deletions src/Fusion/Plugin.hs
View file
Original file line number Diff line number Diff line change
Expand Up @@ -58,36 +58,6 @@ import Data.Generics.Schemes (everywhere)
import Data.Generics.Aliases (mkT)
import Debug.Trace (trace)
import qualified Data.List as DL

-- Imports for specific compiler versions
#if MIN_VERSION_ghc(9,2,0)
import Data.Char (isSpace)
import Text.Printf (printf)
import GHC.Core.Ppr (pprCoreBindingsWithSize, pprRules)
import GHC.Types.Name.Ppr (mkPrintUnqualified)
import GHC.Utils.Logger (Logger)
#endif

-- dump-core option related imports
#if MIN_VERSION_ghc(9,3,0)
import GHC.Utils.Logger (putDumpFile, logFlags, LogFlags(..))
#elif MIN_VERSION_ghc(9,2,0)
import GHC.Utils.Logger (putDumpMsg)
#elif MIN_VERSION_ghc(9,0,0)
-- dump core option not supported
#else
import Control.Monad (unless)
import Data.Char (isSpace)
import Data.IORef (readIORef, writeIORef)
import Data.Time (getCurrentTime)
import System.Directory (createDirectoryIfMissing)
import System.FilePath ((</>), takeDirectory)
import System.IO (Handle, IOMode(..), withFile, hSetEncoding, utf8)
import Text.Printf (printf)
import ErrUtils (mkDumpDoc, Severity(..))
import PprCore (pprCoreBindingsWithSize, pprRules)
import qualified Data.Set as Set
#endif
#endif

-- Implicit imports
Expand All @@ -101,6 +71,10 @@ import GhcPlugins
-- Imports from this package
import Fusion.Plugin.Types (Fuse(..))

#if MIN_VERSION_ghc(8,6,0)
import qualified Fusion.Plugin.Ghc
#endif

-- $using
--
-- This plugin was primarily motivated by fusion issues discovered in
Expand Down Expand Up @@ -684,34 +658,7 @@ fusionMarkInline pass opt failIt transform =
-------------------------------------------------------------------------------

fusionSimplify :: HscEnv -> DynFlags -> CoreToDo
fusionSimplify _hsc_env dflags =
let mode =
SimplMode
{ sm_phase = InitialPhase
, sm_names = ["Fusion Plugin Inlining"]
, sm_dflags = dflags
, sm_rules = gopt Opt_EnableRewriteRules dflags
, sm_eta_expand = gopt Opt_DoLambdaEtaExpansion dflags
, sm_inline = True
, sm_case_case = True
#if MIN_VERSION_ghc(9,2,0)
, sm_uf_opts = unfoldingOpts dflags
, sm_pre_inline = gopt Opt_SimplPreInlining dflags
, sm_logger = hsc_logger _hsc_env
#endif
#if MIN_VERSION_ghc(9,2,2)
, sm_cast_swizzle = True
#endif
#if MIN_VERSION_ghc(9,5,0)
, sm_float_enable = floatEnable dflags
#endif
}
in CoreDoSimplify
#if MIN_VERSION_ghc(9,5,0)
(CoreDoSimplifyOpts (maxSimplIterations dflags) mode)
#else
(maxSimplIterations dflags) mode
#endif
fusionSimplify = Fusion.Plugin.Ghc.coreToDo

-------------------------------------------------------------------------------
-- Report unfused constructors
Expand Down Expand Up @@ -772,209 +719,12 @@ fusionReport mesg reportMode guts = do
-- Dump core passes
-------------------------------------------------------------------------------

-- Only for GHC versions before 9.0.0
#if !MIN_VERSION_ghc(9,0,0)
chooseDumpFile :: DynFlags -> FilePath -> Maybe FilePath
chooseDumpFile dflags suffix
| Just prefix <- getPrefix

= Just $ setDir (prefix ++ suffix)

| otherwise

= Nothing

where getPrefix
-- dump file location is being forced
-- by the --ddump-file-prefix flag.
| Just prefix <- dumpPrefixForce dflags
= Just prefix
-- dump file location chosen by DriverPipeline.runPipeline
| Just prefix <- dumpPrefix dflags
= Just prefix
-- we haven't got a place to put a dump file.
| otherwise
= Nothing
setDir f = case dumpDir dflags of
Just d -> d </> f
Nothing -> f

-- Copied from GHC.Utils.Logger
withDumpFileHandle :: DynFlags -> FilePath -> (Maybe Handle -> IO ()) -> IO ()
withDumpFileHandle dflags suffix action = do
let mFile = chooseDumpFile dflags suffix
case mFile of
Just fileName -> do
let gdref = generatedDumps dflags
gd <- readIORef gdref
let append = Set.member fileName gd
mode = if append then AppendMode else WriteMode
unless append $
writeIORef gdref (Set.insert fileName gd)
createDirectoryIfMissing True (takeDirectory fileName)
withFile fileName mode $ \handle -> do
-- We do not want the dump file to be affected by
-- environment variables, but instead to always use
-- UTF8. See:
-- https://gitlab.haskell.org/ghc/ghc/issues/10762
hSetEncoding handle utf8
action (Just handle)
Nothing -> action Nothing

dumpSDocWithStyle :: PprStyle -> DynFlags -> FilePath -> String -> SDoc -> IO ()
dumpSDocWithStyle sty dflags suffix hdr doc =
withDumpFileHandle dflags suffix writeDump
where
-- write dump to file
writeDump (Just handle) = do
doc' <- if null hdr
then return doc
else do t <- getCurrentTime
let timeStamp = if (gopt Opt_SuppressTimestamps dflags)
then empty
else text (show t)
let d = timeStamp
$$ blankLine
$$ doc
return $ mkDumpDoc hdr d
defaultLogActionHPrintDoc dflags handle doc' sty

-- write the dump to stdout
writeDump Nothing = do
let (doc', severity)
| null hdr = (doc, SevOutput)
| otherwise = (mkDumpDoc hdr doc, SevDump)
putLogMsg dflags NoReason severity noSrcSpan sty doc'

dumpSDoc :: DynFlags -> PrintUnqualified -> FilePath -> String -> SDoc -> IO ()
dumpSDoc dflags print_unqual
= dumpSDocWithStyle dump_style dflags
where dump_style = mkDumpStyle dflags print_unqual
#endif

-- dump core not supported on 9.0.0, 9.0.0 does not export Logger
#if __GLASGOW_HASKELL__!=900
-- Only for GHC versions >= 9.2.0
#if MIN_VERSION_ghc(9,2,0)
dumpPassResult ::
Logger
-> DynFlags
-> PrintUnqualified
-> SDoc -- Header
-> SDoc -- Extra info to appear after header
-> CoreProgram -> [CoreRule]
-> IO ()
dumpPassResult logger dflags unqual hdr extra_info binds rules = do
#if MIN_VERSION_ghc(9,3,0)
let flags = logFlags logger
let getDumpAction = putDumpFile
#else
let flags = dflags
let getDumpAction = putDumpMsg
#endif
(getDumpAction logger)
flags dump_style Opt_D_dump_simpl title undefined dump_doc

where

title = showSDoc dflags hdr

dump_style = mkDumpStyle unqual

#else

dumpPassResult :: DynFlags
-> PrintUnqualified
-> FilePath
-> SDoc -- Header
-> SDoc -- Extra info to appear after header
-> CoreProgram -> [CoreRule]
-> IO ()
dumpPassResult dflags unqual suffix hdr extra_info binds rules = do
dumpSDoc dflags unqual suffix (showSDoc dflags hdr) dump_doc

where

#endif
dump_doc = vcat [ nest 2 extra_info
, blankLine
, pprCoreBindingsWithSize binds
, ppUnless (null rules) pp_rules ]
pp_rules = vcat [ blankLine
, text "------ Local rules for imported ids --------"
, pprRules rules ]

filterOutLast :: (a -> Bool) -> [a] -> [a]
filterOutLast _ [] = []
filterOutLast p [x]
| p x = []
| otherwise = [x]
filterOutLast p (x:xs) = x : filterOutLast p xs

dumpResult
#if MIN_VERSION_ghc(9,2,0)
:: Logger
-> DynFlags
#else
:: DynFlags
#endif
-> PrintUnqualified
-> Int
-> SDoc
-> CoreProgram
-> [CoreRule]
-> IO ()
#if MIN_VERSION_ghc(9,2,0)
dumpResult logger dflags print_unqual counter todo binds rules =
dumpPassResult logger1 dflags print_unqual hdr (text "") binds rules
#else
dumpResult dflags print_unqual counter todo binds rules =
dumpPassResult
dflags print_unqual (_suffix ++ "dump-simpl") hdr (text "") binds rules
#endif

where

hdr = text "["
GhcPlugins.<> int counter
GhcPlugins.<> text "] "
GhcPlugins.<> todo

_suffix = printf "%02d" counter ++ "-"
++ (map (\x -> if isSpace x then '-' else x)
$ filterOutLast isSpace
$ takeWhile (/= '(')
$ showSDoc dflags todo)
++ "."

#if MIN_VERSION_ghc(9,4,0)
prefix = log_dump_prefix (logFlags logger) ++ _suffix
logger1 = logger {logFlags = (logFlags logger) {log_dump_prefix = prefix}}
#elif MIN_VERSION_ghc(9,2,0)
logger1 = logger
#endif
#endif

dumpCore :: Int -> SDoc -> ModGuts -> CoreM ModGuts
dumpCore counter title guts = do
dflags <- getDynFlags
putMsgS $ "fusion-plugin: dumping core "
++ show counter ++ " " ++ showSDoc dflags title

#if MIN_VERSION_ghc(9,2,0)
hscEnv <- getHscEnv
let logger = hsc_logger hscEnv
let print_unqual =
mkPrintUnqualified (hsc_unit_env hscEnv) (mg_rdr_env guts)
liftIO $ dumpResult logger dflags print_unqual counter
title (mg_binds guts) (mg_rules guts)
#elif MIN_VERSION_ghc(9,0,0)
putMsgS $ "fusion-plugin: dump-core not supported on GHC 9.0 "
#else
let print_unqual = mkPrintUnqualified dflags (mg_rdr_env guts)
liftIO $ dumpResult dflags print_unqual counter
title (mg_binds guts) (mg_rules guts)
#endif
Fusion.Plugin.Ghc.dumpCore counter title guts
return guts

dumpCorePass :: Int -> SDoc -> CoreToDo
Expand Down Expand Up @@ -1002,19 +752,10 @@ insertAfterSimplPhase0 origTodos ourTodos report =
where
go False [] = error "Simplifier phase 0/\"main\" not found"
go True [] = []
#if MIN_VERSION_ghc(9,5,0)
go _ (todo@(CoreDoSimplify (CoreDoSimplifyOpts _ SimplMode
{ sm_phase = Phase 0
, sm_names = ["main"]
})):todos)
#else
go _ (todo@(CoreDoSimplify _ SimplMode
{ sm_phase = Phase 0
, sm_names = ["main"]
}):todos)
#endif
= todo : ourTodos ++ go True todos
go found (todo:todos) = todo : go found todos
go found (todo:todos) =
if Fusion.Plugin.Ghc.isPhase0MainTodo todo
then todo : ourTodos ++ go True todos
else todo : go found todos

install :: [CommandLineOption] -> [CoreToDo] -> CoreM [CoreToDo]
install args todos = do
Expand Down Expand Up @@ -1058,9 +799,6 @@ install _ todos = do
#endif

plugin :: Plugin
plugin = defaultPlugin
plugin = Fusion.Plugin.Ghc.defaultPurePlugin
{ installCoreToDos = install
#if MIN_VERSION_ghc(8,6,0)
, pluginRecompile = purePlugin
#endif
}
36 changes: 36 additions & 0 deletions src/Fusion/Plugin/Ghc.hs
View file
Original file line number Diff line number Diff line change
@@ -0,0 +1,36 @@
-- |
-- Module : Fusion.Plugin.Ghc
-- Copyright : (c) 2022 Composewell Technologies
--
-- License : Apache-2.0
-- Maintainer : [email protected]
-- Stability : experimental
-- Portability : GHC

{-# LANGUAGE CPP #-}

module Fusion.Plugin.Ghc
#if MIN_VERSION_ghc(8,6,0)
( coreToDo
, dumpCore
, isPhase0MainTodo
, defaultPurePlugin
)
where

#if MIN_VERSION_ghc(9,5,0)
import Fusion.Plugin.GhcHead
#elif MIN_VERSION_ghc(9,4,0)
import Fusion.Plugin.Ghc940
#elif MIN_VERSION_ghc(9,3,0)
import Fusion.Plugin.Ghc930
#elif MIN_VERSION_ghc(9,2,2)
import Fusion.Plugin.Ghc922
#elif MIN_VERSION_ghc(9,2,0)
import Fusion.Plugin.Ghc920
#elif MIN_VERSION_ghc(9,0,0)
import Fusion.Plugin.Ghc900
#elif MIN_VERSION_ghc(8,6,0)
import Fusion.Plugin.Ghc860
#endif
#endif
Loading

0 comments on commit 3e986e1

Please sign in to comment.