LLVM refactor cleanups

Slightly more documentation, removed unused label map (huh), removed MonadIO instance on LlvmM to improve encapsulation.
ghc · Jun 27, 2013 · fe44d05 · fe44d05
1 parent a948fe8
commit fe44d05
Show file tree

Hide file tree

Showing 3 changed files with 34 additions and 28 deletions.
diff --git a/compiler/llvmGen/Llvm/MetaData.hs b/compiler/llvmGen/Llvm/MetaData.hs
@@ -54,7 +54,6 @@ module Llvm.MetaData where
 
 import Llvm.Types
 
-import FastString
 import Outputable
 
 -- | LLVM metadata expressions

diff --git a/compiler/llvmGen/LlvmCodeGen.hs b/compiler/llvmGen/LlvmCodeGen.hs
@@ -26,7 +26,6 @@ import FastString
 import Outputable
 import UniqSupply
 import SysTools ( figureLlvmVersion )
-import MonadUtils
 import qualified Stream
 
 import Control.Monad ( when )
@@ -132,8 +131,7 @@ cmmLlvmGen cmm@CmmProc{} = do
     let fixed_cmm = {-# SCC "llvm_fix_regs" #-}
                     fixStgRegisters dflags cmm
 
-    liftIO $ dumpIfSet_dyn dflags Opt_D_dump_opt_cmm "Optimised Cmm"
-        (pprCmmGroup [fixed_cmm])
+    dumpIfSetLlvm Opt_D_dump_opt_cmm "Optimised Cmm" (pprCmmGroup [fixed_cmm])
 
     -- generate llvm code from cmm
     llvmBC <- withClearVars $ genLlvmProc fixed_cmm

diff --git a/compiler/llvmGen/LlvmCodeGen/Base.hs b/compiler/llvmGen/LlvmCodeGen/Base.hs
@@ -17,7 +17,7 @@ module LlvmCodeGen.Base (
         runLlvm, liftStream, withClearVars, varLookup, varInsert,
         markStackReg, checkStackReg,
         funLookup, funInsert, getLlvmVer, getDynFlags, getDynFlag, getLlvmPlatform,
-        renderLlvm, runUs, markUsedVar, getUsedVars,
+        dumpIfSetLlvm, renderLlvm, runUs, markUsedVar, getUsedVars,
         ghcInternalFunctions,
 
         getMetaUniqueId,
@@ -48,7 +48,6 @@ import qualified Pretty as Prt
 import Platform
 import UniqFM
 import Unique
-import MonadUtils ( MonadIO(..) )
 import BufWrite   ( BufHandle )
 import UniqSet
 import UniqSupply
@@ -190,19 +189,20 @@ maxSupportLlvmVersion = 33
 --
 
 data LlvmEnv = LlvmEnv
-  { envFunMap :: LlvmEnvMap
-  , envVarMap :: LlvmEnvMap
-  , envStackRegs :: [GlobalReg]
-  , envUsedVars :: [LlvmVar]
-  , envAliases :: UniqSet LMString
-  , envLabelMap :: [(CLabel, CLabel)]
-  , envVersion :: LlvmVersion
-  , envDynFlags :: DynFlags
-  , envOutput :: BufHandle
-  , envUniq :: UniqSupply
-  , envFreshMeta :: Int
-  , envUniqMeta :: UniqFM Int
-  , envNextSection :: Int
+  { envVersion :: LlvmVersion      -- ^ LLVM version
+  , envDynFlags :: DynFlags        -- ^ Dynamic flags
+  , envOutput :: BufHandle         -- ^ Output buffer
+  , envUniq :: UniqSupply          -- ^ Supply of unique values
+  , envNextSection :: Int          -- ^ Supply of fresh section IDs
+  , envFreshMeta :: Int            -- ^ Supply of fresh metadata IDs
+  , envUniqMeta :: UniqFM Int      -- ^ Global metadata nodes
+  , envFunMap :: LlvmEnvMap        -- ^ Global functions so far, with type
+  , envAliases :: UniqSet LMString -- ^ Globals that we had to alias, see [Llvm Forward References]
+  , envUsedVars :: [LlvmVar]       -- ^ Pointers to be added to llvm.used (see @cmmUsedLlvmGens@)
+
+    -- the following get cleared for every function (see @withClearVars@)
+  , envVarMap :: LlvmEnvMap        -- ^ Local variables so far, with type
+  , envStackRegs :: [GlobalReg]    -- ^ Non-constant registers (alloca'd in the function prelude)
   }
 
 type LlvmEnvMap = UniqFM LlvmType
@@ -216,13 +216,15 @@ instance Monad LlvmM where
 instance Functor LlvmM where
     fmap f m = LlvmM $ \env -> do (x, env') <- runLlvmM m env
                                   return (f x, env')
-instance MonadIO LlvmM where
-    liftIO m = LlvmM $ \env -> do x <- m
-                                  return (x, env)
 
 instance HasDynFlags LlvmM where
     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.
 runLlvm :: DynFlags -> LlvmVersion -> BufHandle -> UniqSupply -> LlvmM () -> IO ()
 runLlvm dflags ver out us m = do
@@ -233,7 +235,6 @@ runLlvm dflags ver out us m = do
                       , envStackRegs = []
                       , envUsedVars = []
                       , envAliases = emptyUniqSet
-                      , envLabelMap = []
                       , envVersion = ver
                       , envDynFlags = dflags
                       , envOutput = out
@@ -299,17 +300,25 @@ getDynFlag f = getEnv (f . envDynFlags)
 getLlvmPlatform :: LlvmM Platform
 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
 renderLlvm :: Outp.SDoc -> LlvmM ()
-renderLlvm sdoc = LlvmM $ \env -> do
+renderLlvm sdoc = do
 
     -- Write to output
-    let doc = Outp.withPprStyleDoc (envDynFlags env) (Outp.mkCodeStyle Outp.CStyle) sdoc
-    Prt.bufLeftRender (envOutput env) doc
+    dflags <- getDynFlags
+    out <- getEnv envOutput
+    let doc = Outp.withPprStyleDoc dflags (Outp.mkCodeStyle Outp.CStyle) sdoc
+    liftIO $ Prt.bufLeftRender out doc
 
     -- Dump, if requested
-    dumpIfSet_dyn (envDynFlags env) Opt_D_dump_llvm "LLVM Code" sdoc
-    return ((), env)
+    dumpIfSetLlvm Opt_D_dump_llvm "LLVM Code" sdoc
+    return ()
 
 -- | Run a @UniqSM@ action with our unique supply
 runUs :: UniqSM a -> LlvmM a