Commit fe44d053 authored by Peter Wortmann's avatar Peter Wortmann Committed by dterei

LLVM refactor cleanups

Slightly more documentation, removed unused label map (huh),
removed MonadIO instance on LlvmM to improve encapsulation.
parent a948fe83
...@@ -54,7 +54,6 @@ module Llvm.MetaData where ...@@ -54,7 +54,6 @@ module Llvm.MetaData where
import Llvm.Types import Llvm.Types
import FastString
import Outputable import Outputable
-- | LLVM metadata expressions -- | LLVM metadata expressions
......
...@@ -26,7 +26,6 @@ import FastString ...@@ -26,7 +26,6 @@ import FastString
import Outputable import Outputable
import UniqSupply import UniqSupply
import SysTools ( figureLlvmVersion ) import SysTools ( figureLlvmVersion )
import MonadUtils
import qualified Stream import qualified Stream
import Control.Monad ( when ) import Control.Monad ( when )
...@@ -132,8 +131,7 @@ cmmLlvmGen cmm@CmmProc{} = do ...@@ -132,8 +131,7 @@ cmmLlvmGen cmm@CmmProc{} = do
let fixed_cmm = {-# SCC "llvm_fix_regs" #-} let fixed_cmm = {-# SCC "llvm_fix_regs" #-}
fixStgRegisters dflags cmm fixStgRegisters dflags cmm
liftIO $ dumpIfSet_dyn dflags Opt_D_dump_opt_cmm "Optimised Cmm" dumpIfSetLlvm Opt_D_dump_opt_cmm "Optimised Cmm" (pprCmmGroup [fixed_cmm])
(pprCmmGroup [fixed_cmm])
-- generate llvm code from cmm -- generate llvm code from cmm
llvmBC <- withClearVars $ genLlvmProc fixed_cmm llvmBC <- withClearVars $ genLlvmProc fixed_cmm
......
...@@ -17,7 +17,7 @@ module LlvmCodeGen.Base ( ...@@ -17,7 +17,7 @@ module LlvmCodeGen.Base (
runLlvm, liftStream, withClearVars, varLookup, varInsert, runLlvm, liftStream, withClearVars, varLookup, varInsert,
markStackReg, checkStackReg, markStackReg, checkStackReg,
funLookup, funInsert, getLlvmVer, getDynFlags, getDynFlag, getLlvmPlatform, funLookup, funInsert, getLlvmVer, getDynFlags, getDynFlag, getLlvmPlatform,
renderLlvm, runUs, markUsedVar, getUsedVars, dumpIfSetLlvm, renderLlvm, runUs, markUsedVar, getUsedVars,
ghcInternalFunctions, ghcInternalFunctions,
getMetaUniqueId, getMetaUniqueId,
...@@ -48,7 +48,6 @@ import qualified Pretty as Prt ...@@ -48,7 +48,6 @@ import qualified Pretty as Prt
import Platform import Platform
import UniqFM import UniqFM
import Unique import Unique
import MonadUtils ( MonadIO(..) )
import BufWrite ( BufHandle ) import BufWrite ( BufHandle )
import UniqSet import UniqSet
import UniqSupply import UniqSupply
...@@ -190,19 +189,20 @@ maxSupportLlvmVersion = 33 ...@@ -190,19 +189,20 @@ maxSupportLlvmVersion = 33
-- --
data LlvmEnv = LlvmEnv data LlvmEnv = LlvmEnv
{ envFunMap :: LlvmEnvMap { envVersion :: LlvmVersion -- ^ LLVM version
, envVarMap :: LlvmEnvMap , envDynFlags :: DynFlags -- ^ Dynamic flags
, envStackRegs :: [GlobalReg] , envOutput :: BufHandle -- ^ Output buffer
, envUsedVars :: [LlvmVar] , envUniq :: UniqSupply -- ^ Supply of unique values
, envAliases :: UniqSet LMString , envNextSection :: Int -- ^ Supply of fresh section IDs
, envLabelMap :: [(CLabel, CLabel)] , envFreshMeta :: Int -- ^ Supply of fresh metadata IDs
, envVersion :: LlvmVersion , envUniqMeta :: UniqFM Int -- ^ Global metadata nodes
, envDynFlags :: DynFlags , envFunMap :: LlvmEnvMap -- ^ Global functions so far, with type
, envOutput :: BufHandle , envAliases :: UniqSet LMString -- ^ Globals that we had to alias, see [Llvm Forward References]
, envUniq :: UniqSupply , envUsedVars :: [LlvmVar] -- ^ Pointers to be added to llvm.used (see @cmmUsedLlvmGens@)
, envFreshMeta :: Int
, envUniqMeta :: UniqFM Int -- the following get cleared for every function (see @withClearVars@)
, envNextSection :: Int , envVarMap :: LlvmEnvMap -- ^ Local variables so far, with type
, envStackRegs :: [GlobalReg] -- ^ Non-constant registers (alloca'd in the function prelude)
} }
type LlvmEnvMap = UniqFM LlvmType type LlvmEnvMap = UniqFM LlvmType
...@@ -216,13 +216,15 @@ instance Monad LlvmM where ...@@ -216,13 +216,15 @@ instance Monad LlvmM where
instance Functor LlvmM where instance Functor LlvmM where
fmap f m = LlvmM $ \env -> do (x, env') <- runLlvmM m env fmap f m = LlvmM $ \env -> do (x, env') <- runLlvmM m env
return (f x, env') return (f x, env')
instance MonadIO LlvmM where
liftIO m = LlvmM $ \env -> do x <- m
return (x, env)
instance HasDynFlags LlvmM where instance HasDynFlags LlvmM where
getDynFlags = LlvmM $ \env -> return (envDynFlags env, env) getDynFlags = LlvmM $ \env -> return (envDynFlags env, env)
-- | Lifting of IO actions. Not exported, as we want to encapsulate IO.
liftIO :: IO a -> LlvmM a
liftIO m = LlvmM $ \env -> do x <- m
return (x, env)
-- | Get initial Llvm environment. -- | Get initial Llvm environment.
runLlvm :: DynFlags -> LlvmVersion -> BufHandle -> UniqSupply -> LlvmM () -> IO () runLlvm :: DynFlags -> LlvmVersion -> BufHandle -> UniqSupply -> LlvmM () -> IO ()
runLlvm dflags ver out us m = do runLlvm dflags ver out us m = do
...@@ -233,7 +235,6 @@ runLlvm dflags ver out us m = do ...@@ -233,7 +235,6 @@ runLlvm dflags ver out us m = do
, envStackRegs = [] , envStackRegs = []
, envUsedVars = [] , envUsedVars = []
, envAliases = emptyUniqSet , envAliases = emptyUniqSet
, envLabelMap = []
, envVersion = ver , envVersion = ver
, envDynFlags = dflags , envDynFlags = dflags
, envOutput = out , envOutput = out
...@@ -299,17 +300,25 @@ getDynFlag f = getEnv (f . envDynFlags) ...@@ -299,17 +300,25 @@ getDynFlag f = getEnv (f . envDynFlags)
getLlvmPlatform :: LlvmM Platform getLlvmPlatform :: LlvmM Platform
getLlvmPlatform = getDynFlag targetPlatform getLlvmPlatform = getDynFlag targetPlatform
-- | Dumps the document if the corresponding flag has been set by the user
dumpIfSetLlvm :: DumpFlag -> String -> Outp.SDoc -> LlvmM ()
dumpIfSetLlvm flag hdr doc = do
dflags <- getDynFlags
liftIO $ dumpIfSet_dyn dflags flag hdr doc
-- | Prints the given contents to the output handle -- | Prints the given contents to the output handle
renderLlvm :: Outp.SDoc -> LlvmM () renderLlvm :: Outp.SDoc -> LlvmM ()
renderLlvm sdoc = LlvmM $ \env -> do renderLlvm sdoc = do
-- Write to output -- Write to output
let doc = Outp.withPprStyleDoc (envDynFlags env) (Outp.mkCodeStyle Outp.CStyle) sdoc dflags <- getDynFlags
Prt.bufLeftRender (envOutput env) doc out <- getEnv envOutput
let doc = Outp.withPprStyleDoc dflags (Outp.mkCodeStyle Outp.CStyle) sdoc
liftIO $ Prt.bufLeftRender out doc
-- Dump, if requested -- Dump, if requested
dumpIfSet_dyn (envDynFlags env) Opt_D_dump_llvm "LLVM Code" sdoc dumpIfSetLlvm Opt_D_dump_llvm "LLVM Code" sdoc
return ((), env) return ()
-- | Run a @UniqSM@ action with our unique supply -- | Run a @UniqSM@ action with our unique supply
runUs :: UniqSM a -> LlvmM a runUs :: UniqSM a -> LlvmM a
......
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