[commit: ghc] ghc-8.0: Add MonadUnique instance for LlvmM (5f66ae5)

[git at git.haskell.org]

Repository : ssh://git@git.haskell.org/ghc

On branch  : ghc-8.0
Link       : http://ghc.haskell.org/trac/ghc/changeset/5f66ae571b237853953e0e479a012a10980c4307/ghc

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

commit 5f66ae571b237853953e0e479a012a10980c4307
Author: Ben Gamari <bgamari.foss at gmail.com>
Date:   Fri Mar 11 10:41:05 2016 +0100

    Add MonadUnique instance for LlvmM
    
    Reviewers: erikd, austin
    
    Reviewed By: erikd
    
    Subscribers: thomie
    
    Differential Revision: https://phabricator.haskell.org/D1994
    
    (cherry picked from commit 6a2992dc4b6582bd95b0cef1a674a99ca8299403)


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

5f66ae571b237853953e0e479a012a10980c4307
 compiler/llvmGen/LlvmCodeGen/Base.hs    | 21 ++++++++++++++-------
 compiler/llvmGen/LlvmCodeGen/CodeGen.hs |  4 ++--
 2 files changed, 16 insertions(+), 9 deletions(-)

diff --git a/compiler/llvmGen/LlvmCodeGen/Base.hs b/compiler/llvmGen/LlvmCodeGen/Base.hs
index 82c1eea..cbd4c68 100644
--- a/compiler/llvmGen/LlvmCodeGen/Base.hs
+++ b/compiler/llvmGen/LlvmCodeGen/Base.hs
@@ -18,7 +18,7 @@ module LlvmCodeGen.Base (
         runLlvm, liftStream, withClearVars, varLookup, varInsert,
         markStackReg, checkStackReg,
         funLookup, funInsert, getLlvmVer, getDynFlags, getDynFlag, getLlvmPlatform,
-        dumpIfSetLlvm, renderLlvm, runUs, markUsedVar, getUsedVars,
+        dumpIfSetLlvm, renderLlvm, markUsedVar, getUsedVars,
         ghcInternalFunctions,
 
         getMetaUniqueId,
@@ -228,6 +228,19 @@ instance Monad LlvmM where
 instance HasDynFlags LlvmM where
     getDynFlags = LlvmM $ \env -> return (envDynFlags env, env)
 
+instance MonadUnique LlvmM where
+    getUniqueSupplyM = do
+        us <- getEnv envUniq
+        let (us1, us2) = splitUniqSupply us
+        modifyEnv (\s -> s { envUniq = us2 })
+        return us1
+
+    getUniqueM = do
+        us <- getEnv envUniq
+        let (u,us') = takeUniqFromSupply us
+        modifyEnv (\s -> s { envUniq = us' })
+        return u
+
 -- | Lifting of IO actions. Not exported, as we want to encapsulate IO.
 liftIO :: IO a -> LlvmM a
 liftIO m = LlvmM $ \env -> do x <- m
@@ -327,12 +340,6 @@ renderLlvm sdoc = do
     dumpIfSetLlvm Opt_D_dump_llvm "LLVM Code" sdoc
     return ()
 
--- | Run a @UniqSM@ action with our unique supply
-runUs :: UniqSM a -> LlvmM a
-runUs m = LlvmM $ \env -> do
-    let (x, us') = initUs (envUniq env) m
-    return (x, env { envUniq = us' })
-
 -- | Marks a variable as "used"
 markUsedVar :: LlvmVar -> LlvmM ()
 markUsedVar v = modifyEnv $ \env -> env { envUsedVars = v : envUsedVars env }
diff --git a/compiler/llvmGen/LlvmCodeGen/CodeGen.hs b/compiler/llvmGen/LlvmCodeGen/CodeGen.hs
index 61c059d..04223fd 100644
--- a/compiler/llvmGen/LlvmCodeGen/CodeGen.hs
+++ b/compiler/llvmGen/LlvmCodeGen/CodeGen.hs
@@ -148,7 +148,7 @@ getInstrinct2 fname fty@(LMFunction funSig) = do
         return []
       Nothing -> do
         funInsert fname fty
-        un <- runUs getUniqueM
+        un <- getUniqueM
         let lbl = mkAsmTempLabel un
         return [CmmData (Section Data lbl) [([],[fty])]]
 
@@ -1787,7 +1787,7 @@ getHsFunc' name fty
 -- | Create a new local var
 mkLocalVar :: LlvmType -> LlvmM LlvmVar
 mkLocalVar ty = do
-    un <- runUs getUniqueM
+    un <- getUniqueM
     return $ LMLocalVar un ty