[commit: ghc] master: LLVM refactor cleanups (fe44d05)

[David Terei]

Repository : http://darcs.haskell.org/ghc.git/

On branch  : master

https://github.com/ghc/ghc/commit/fe44d053e10df05b4648bb23fb09e2beb9b43f22

>---------------------------------------------------------------

commit fe44d053e10df05b4648bb23fb09e2beb9b43f22
Author: Peter Wortmann <scpmw at leeds.ac.uk>
Date:   Thu Jun 27 14:53:03 2013 +0100

    LLVM refactor cleanups
    
    Slightly more documentation, removed unused label map (huh),
    removed MonadIO instance on LlvmM to improve encapsulation.

>---------------------------------------------------------------

 compiler/llvmGen/Llvm/MetaData.hs    |  1 -
 compiler/llvmGen/LlvmCodeGen.hs      |  4 +--
 compiler/llvmGen/LlvmCodeGen/Base.hs | 57 +++++++++++++++++++++---------------
 3 files changed, 34 insertions(+), 28 deletions(-)

diff --git a/compiler/llvmGen/Llvm/MetaData.hs b/compiler/llvmGen/Llvm/MetaData.hs
index 364403e..dda3ca0 100644
--- 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
index 4c5fa65..d0f343f 100644
--- 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 at 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
index 95d3abd..ef0ab3b 100644
--- 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