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

Major Llvm refactoring

This combined patch reworks the LLVM backend in a number of ways:

1. Most prominently, we introduce a LlvmM monad carrying the contents of
   the old LlvmEnv around. This patch completely removes LlvmEnv and
   refactors towards standard library monad combinators wherever possible.

2. Support for streaming - we can now generate chunks of Llvm for Cmm as
   it comes in. This might improve our speed.

3. To allow streaming, we need a more flexible way to handle forward
   references. The solution (getGlobalPtr) unifies LlvmCodeGen.Data
   and getHsFunc as well.

4. Skip alloca-allocation for registers that are actually never written.
   LLVM will automatically eliminate these, but output is smaller and
   friendlier to human eyes this way.

5. We use LlvmM to collect references for llvm.used. This allows places
   other than cmmProcLlvmGens to generate entries.
parent fa6cbdfb
......@@ -623,6 +623,8 @@ data LlvmLinkageType
-- | Alias for 'ExternallyVisible' but with explicit textual form in LLVM
-- assembly.
| External
-- | Symbol is private to the module and should not appear in the symbol table
| Private
deriving (Eq)
instance Outputable LlvmLinkageType where
......
......@@ -11,6 +11,7 @@ import LlvmCodeGen.Base
import LlvmCodeGen.CodeGen
import LlvmCodeGen.Data
import LlvmCodeGen.Ppr
import LlvmCodeGen.Regs
import LlvmMangler
import CgUtils ( fixStgRegisters )
......@@ -23,143 +24,175 @@ import DynFlags
import ErrUtils
import FastString
import Outputable
import qualified Pretty as Prt
import UniqSupply
import Util
import SysTools ( figureLlvmVersion )
import MonadUtils
import qualified Stream
import Control.Monad ( when )
import Data.IORef ( writeIORef )
import Data.Maybe ( fromMaybe )
import Data.Maybe ( fromMaybe, catMaybes )
import System.IO
-- -----------------------------------------------------------------------------
-- | Top-level of the LLVM Code generator
--
llvmCodeGen :: DynFlags -> Handle -> UniqSupply -> [RawCmmGroup] -> IO ()
llvmCodeGen dflags h us cmms
= let cmm = concat cmms
(cdata,env) = {-# SCC "llvm_split" #-}
foldr split ([], initLlvmEnv dflags) cmm
split (CmmData s d' ) (d,e) = ((s,d'):d,e)
split (CmmProc h l live g) (d,e) =
let lbl = strCLabel_llvm env $
case mapLookup (g_entry g) h of
Nothing -> l
Just (Statics info_lbl _) -> info_lbl
env' = funInsert lbl (llvmFunTy dflags live) e
in (d,env')
in do
showPass dflags "LlVM CodeGen"
dumpIfSet_dyn dflags Opt_D_dump_llvm "LLVM Code" pprLlvmHeader
bufh <- newBufHandle h
Prt.bufLeftRender bufh $ withPprStyleDoc dflags (mkCodeStyle CStyle) pprLlvmHeader
ver <- getLlvmVersion
env' <- {-# SCC "llvm_datas_gen" #-}
cmmDataLlvmGens dflags bufh (setLlvmVer ver env) cdata []
{-# SCC "llvm_procs_gen" #-}
cmmProcLlvmGens dflags bufh us env' cmm 1 []
bFlush bufh
return ()
where
-- | Handle setting up the LLVM version.
getLlvmVersion = do
ver <- (fromMaybe defaultLlvmVersion) `fmap` figureLlvmVersion dflags
-- cache llvm version for later use
writeIORef (llvmVersion dflags) ver
debugTraceMsg dflags 2
(text "Using LLVM version:" <+> text (show ver))
let doWarn = wopt Opt_WarnUnsupportedLlvmVersion dflags
when (ver < minSupportLlvmVersion && doWarn) $
errorMsg dflags (text "You are using an old version of LLVM that"
<> text " isn't supported anymore!"
$+$ text "We will try though...")
when (ver > maxSupportLlvmVersion && doWarn) $
putMsg dflags (text "You are using a new version of LLVM that"
<> text " hasn't been tested yet!"
$+$ text "We will try though...")
return ver
llvmCodeGen :: DynFlags -> Handle -> UniqSupply
-> Stream.Stream IO RawCmmGroup ()
-> IO ()
llvmCodeGen dflags h us cmm_stream
= do bufh <- newBufHandle h
-- Pass header
showPass dflags "LLVM CodeGen"
-- get llvm version, cache for later use
ver <- (fromMaybe defaultLlvmVersion) `fmap` figureLlvmVersion dflags
writeIORef (llvmVersion dflags) ver
-- warn if unsupported
debugTraceMsg dflags 2
(text "Using LLVM version:" <+> text (show ver))
let doWarn = wopt Opt_WarnUnsupportedLlvmVersion dflags
when (ver < minSupportLlvmVersion && doWarn) $
errorMsg dflags (text "You are using an old version of LLVM that"
<> text " isn't supported anymore!"
$+$ text "We will try though...")
when (ver > maxSupportLlvmVersion && doWarn) $
putMsg dflags (text "You are using a new version of LLVM that"
<> text " hasn't been tested yet!"
$+$ text "We will try though...")
-- run code generation
runLlvm dflags ver bufh us $
llvmCodeGen' (liftStream cmm_stream)
bFlush bufh
llvmCodeGen' :: Stream.Stream LlvmM RawCmmGroup () -> LlvmM ()
llvmCodeGen' cmm_stream
= do -- Preamble
renderLlvm pprLlvmHeader
ghcInternalFunctions
cmmMetaLlvmPrelude
-- Procedures
let llvmStream = Stream.mapM llvmGroupLlvmGens cmm_stream
_ <- Stream.collect llvmStream
-- Declare aliases for forward references
renderLlvm . pprLlvmData =<< generateAliases
-- Postamble
cmmUsedLlvmGens
llvmGroupLlvmGens :: RawCmmGroup -> LlvmM ()
llvmGroupLlvmGens cmm = do
-- Insert functions into map, collect data
let split (CmmData s d' ) = return $ Just (s, d')
split (CmmProc h l live g) = do
-- Set function type
let l' = case mapLookup (g_entry g) h of
Nothing -> l
Just (Statics info_lbl _) -> info_lbl
lml <- strCLabel_llvm l'
funInsert lml =<< llvmFunTy live
return Nothing
cdata <- fmap catMaybes $ mapM split cmm
{-# SCC "llvm_datas_gen" #-}
cmmDataLlvmGens cdata
{-# SCC "llvm_procs_gen" #-}
mapM_ cmmLlvmGen cmm
-- -----------------------------------------------------------------------------
-- | Do LLVM code generation on all these Cmms data sections.
--
cmmDataLlvmGens :: DynFlags -> BufHandle -> LlvmEnv -> [(Section,CmmStatics)]
-> [LlvmUnresData] -> IO ( LlvmEnv )
cmmDataLlvmGens dflags h env [] lmdata
= let (env', lmdata') = {-# SCC "llvm_resolve" #-}
resolveLlvmDatas env lmdata
lmdoc = {-# SCC "llvm_data_ppr" #-}
vcat $ map pprLlvmData lmdata'
in do
dumpIfSet_dyn dflags Opt_D_dump_llvm "LLVM Code" lmdoc
{-# SCC "llvm_data_out" #-}
Prt.bufLeftRender h $ withPprStyleDoc dflags (mkCodeStyle CStyle) lmdoc
return env'
cmmDataLlvmGens dflags h env (cmm:cmms) lmdata
= let lm@(l, _, ty, _) = {-# SCC "llvm_data_gen" #-}
genLlvmData env cmm
env' = {-# SCC "llvm_data_insert" #-}
funInsert (strCLabel_llvm env l) ty env
lmdata' = {-# SCC "llvm_data_append" #-}
lm:lmdata
in cmmDataLlvmGens dflags h env' cmms lmdata'
cmmDataLlvmGens :: [(Section,CmmStatics)] -> LlvmM ()
cmmDataLlvmGens statics
= do lmdatas <- mapM genLlvmData statics
-- -----------------------------------------------------------------------------
-- | Do LLVM code generation on all these Cmms procs.
--
cmmProcLlvmGens :: DynFlags -> BufHandle -> UniqSupply -> LlvmEnv -> [RawCmmDecl]
-> Int -- ^ count, used for generating unique subsections
-> [[LlvmVar]] -- ^ info tables that need to be marked as 'used'
-> IO ()
cmmProcLlvmGens dflags h _ _ [] _ ivars
| null ivars' = return ()
| otherwise = Prt.bufLeftRender h $
{-# SCC "llvm_used_ppr" #-}
withPprStyleDoc dflags (mkCodeStyle CStyle) $
pprLlvmData ([lmUsed], [])
where
ivars' = concat ivars
cast x = LMBitc (LMStaticPointer (pVarLift x)) i8Ptr
ty = (LMArray (length ivars') i8Ptr)
usedArray = LMStaticArray (map cast ivars') ty
lmUsedVar = LMGlobalVar (fsLit "llvm.used") ty Appending
(Just $ fsLit "llvm.metadata") Nothing Global
lmUsed = LMGlobal lmUsedVar (Just usedArray)
cmmProcLlvmGens dflags h us env ((CmmData _ _) : cmms) count ivars
= cmmProcLlvmGens dflags h us env cmms count ivars
cmmProcLlvmGens dflags h us env (cmm : cmms) count ivars = do
(us', env', llvm) <- cmmLlvmGen dflags us (clearVars env) cmm
let (docs, ivar) = mapAndUnzip (pprLlvmCmmDecl env' count) llvm
Prt.bufLeftRender h $ {-# SCC "llvm_proc_ppr" #-}
withPprStyleDoc dflags (mkCodeStyle CStyle) $ vcat docs
cmmProcLlvmGens dflags h us' env' cmms (count + 2) (ivar ++ ivars)
let (gss, tss) = unzip lmdatas
let regGlobal (LMGlobal (LMGlobalVar l ty _ _ _ _) _)
= funInsert l ty
regGlobal _ = return ()
mapM_ regGlobal (concat gss)
renderLlvm $ pprLlvmData (concat gss, concat tss)
-- | Complete LLVM code generation phase for a single top-level chunk of Cmm.
cmmLlvmGen :: DynFlags -> UniqSupply -> LlvmEnv -> RawCmmDecl
-> IO ( UniqSupply, LlvmEnv, [LlvmCmmDecl] )
cmmLlvmGen dflags us env cmm = do
cmmLlvmGen ::RawCmmDecl -> LlvmM ()
cmmLlvmGen cmm@CmmProc{} = do
-- rewrite assignments to global regs
dflags <- getDynFlag id
let fixed_cmm = {-# SCC "llvm_fix_regs" #-}
fixStgRegisters dflags cmm
dumpIfSet_dyn dflags Opt_D_dump_opt_cmm "Optimised Cmm"
liftIO $ dumpIfSet_dyn dflags Opt_D_dump_opt_cmm "Optimised Cmm"
(pprCmmGroup [fixed_cmm])
-- generate llvm code from cmm
let ((env', llvmBC), usGen) = {-# SCC "llvm_proc_gen" #-}
initUs us $ genLlvmProc env fixed_cmm
llvmBC <- withClearVars $ genLlvmProc fixed_cmm
dumpIfSet_dyn dflags Opt_D_dump_llvm "LLVM Code"
(vcat $ map (fst . pprLlvmCmmDecl env' 0) llvmBC)
-- allocate IDs for info table and code, so the mangler can later
-- make sure they end up next to each other.
itableSection <- freshSectionId
_codeSection <- freshSectionId
return (usGen, env', llvmBC)
-- pretty print
(docs, ivars) <- fmap unzip $ mapM (pprLlvmCmmDecl itableSection) llvmBC
-- Output, note down used variables
renderLlvm (vcat docs)
mapM_ markUsedVar $ concat ivars
cmmLlvmGen _ = return ()
-- -----------------------------------------------------------------------------
-- | Generate meta data nodes
--
cmmMetaLlvmPrelude :: LlvmM ()
cmmMetaLlvmPrelude = do
metas <- flip mapM stgTBAA $ \(uniq, name, parent) -> do
-- Generate / lookup meta data IDs
tbaaId <- getMetaUniqueId
setUniqMeta uniq tbaaId
parentId <- maybe (return Nothing) getUniqMeta parent
-- Build definition
return $ MetaUnamed tbaaId $ MetaStruct
[ MetaStr name
, case parentId of
Just p -> MetaNode p
Nothing -> MetaVar $ LMLitVar $ LMNullLit i8Ptr
]
renderLlvm $ ppLlvmMetas metas
-- -----------------------------------------------------------------------------
-- | Marks variables as used where necessary
--
cmmUsedLlvmGens :: LlvmM ()
cmmUsedLlvmGens = do
-- LLVM would discard variables that are internal and not obviously
-- used if we didn't provide these hints. This will generate a
-- definition of the form
--
-- @llvm.used = appending global [42 x i8*] [i8* bitcast <var> to i8*, ...]
--
-- Which is the LLVM way of protecting them against getting removed.
ivars <- getUsedVars
let cast x = LMBitc (LMStaticPointer (pVarLift x)) i8Ptr
ty = (LMArray (length ivars) i8Ptr)
usedArray = LMStaticArray (map cast ivars) ty
sectName = Just $ fsLit "llvm.metadata"
lmUsedVar = LMGlobalVar (fsLit "llvm.used") ty Appending sectName Nothing Constant
lmUsed = LMGlobal lmUsedVar (Just usedArray)
if null ivars
then return ()
else renderLlvm $ pprLlvmData ([lmUsed], [])
......@@ -13,15 +13,23 @@ module LlvmCodeGen.Base (
LlvmVersion, defaultLlvmVersion, minSupportLlvmVersion,
maxSupportLlvmVersion,
LlvmEnv, initLlvmEnv, clearVars, varLookup, varInsert,
funLookup, funInsert, getLlvmVer, setLlvmVer, getLlvmPlatform,
getDflags, ghcInternalFunctions,
LlvmM,
runLlvm, liftStream, withClearVars, varLookup, varInsert,
markStackReg, checkStackReg,
funLookup, funInsert, getLlvmVer, getDynFlags, getDynFlag, getLlvmPlatform,
renderLlvm, runUs, markUsedVar, getUsedVars,
ghcInternalFunctions,
getMetaUniqueId,
setUniqMeta, getUniqMeta,
freshSectionId,
cmmToLlvmType, widthToLlvmFloat, widthToLlvmInt, llvmFunTy,
llvmFunSig, llvmStdFunAttrs, llvmFunAlign, llvmInfAlign,
llvmPtrBits, mkLlvmFunc, tysToParams,
strCLabel_llvm, genCmmLabelRef, genStringLabelRef
strCLabel_llvm, strDisplayName_llvm, strProcedureName_llvm,
getGlobalPtr, generateAliases,
) where
......@@ -36,9 +44,16 @@ import DynFlags
import FastString
import Cmm
import qualified Outputable as Outp
import qualified Pretty as Prt
import Platform
import UniqFM
import Unique
import MonadUtils ( MonadIO(..) )
import BufWrite ( BufHandle )
import UniqSet
import UniqSupply
import ErrUtils
import qualified Stream
-- ----------------------------------------------------------------------------
-- * Some Data Types
......@@ -93,30 +108,32 @@ llvmGhcCC dflags
| otherwise = CC_Ncc 10
-- | Llvm Function type for Cmm function
llvmFunTy :: DynFlags -> LiveGlobalRegs -> LlvmType
llvmFunTy dflags live = LMFunction $ llvmFunSig' dflags live (fsLit "a") ExternallyVisible
llvmFunTy :: LiveGlobalRegs -> LlvmM LlvmType
llvmFunTy live = return . LMFunction =<< llvmFunSig' live (fsLit "a") ExternallyVisible
-- | Llvm Function signature
llvmFunSig :: LlvmEnv -> LiveGlobalRegs -> CLabel -> LlvmLinkageType -> LlvmFunctionDecl
llvmFunSig env live lbl link
= llvmFunSig' (getDflags env) live (strCLabel_llvm env lbl) link
llvmFunSig' :: DynFlags -> LiveGlobalRegs -> LMString -> LlvmLinkageType -> LlvmFunctionDecl
llvmFunSig' dflags live lbl link
= let toParams x | isPointer x = (x, [NoAlias, NoCapture])
| otherwise = (x, [])
in LlvmFunctionDecl lbl link (llvmGhcCC dflags) LMVoid FixedArgs
(map (toParams . getVarType) (llvmFunArgs dflags live))
(llvmFunAlign dflags)
llvmFunSig :: LiveGlobalRegs -> CLabel -> LlvmLinkageType -> LlvmM LlvmFunctionDecl
llvmFunSig live lbl link = do
lbl' <- strCLabel_llvm lbl
llvmFunSig' live lbl' link
llvmFunSig' :: LiveGlobalRegs -> LMString -> LlvmLinkageType -> LlvmM LlvmFunctionDecl
llvmFunSig' live lbl link
= do let toParams x | isPointer x = (x, [NoAlias, NoCapture])
| otherwise = (x, [])
dflags <- getDynFlags
return $ LlvmFunctionDecl lbl link (llvmGhcCC dflags) LMVoid FixedArgs
(map (toParams . getVarType) (llvmFunArgs dflags live))
(llvmFunAlign dflags)
-- | Create a Haskell function in LLVM.
mkLlvmFunc :: LlvmEnv -> LiveGlobalRegs -> CLabel -> LlvmLinkageType -> LMSection -> LlvmBlocks
-> LlvmFunction
mkLlvmFunc env live lbl link sec blks
= let dflags = getDflags env
funDec = llvmFunSig env live lbl link
funArgs = map (fsLit . Outp.showSDoc dflags . ppPlainName) (llvmFunArgs dflags live)
in LlvmFunction funDec funArgs llvmStdFunAttrs sec blks
mkLlvmFunc :: LiveGlobalRegs -> CLabel -> LlvmLinkageType -> LMSection -> LlvmBlocks
-> LlvmM LlvmFunction
mkLlvmFunc live lbl link sec blks
= do funDec <- llvmFunSig live lbl link
dflags <- getDynFlags
let funArgs = map (fsLit . Outp.showSDoc dflags . ppPlainName) (llvmFunArgs dflags live)
return $ LlvmFunction funDec funArgs llvmStdFunAttrs sec blks
-- | Alignment to use for functions
llvmFunAlign :: DynFlags -> LMAlign
......@@ -172,96 +189,276 @@ maxSupportLlvmVersion = 33
-- * Environment Handling
--
-- two maps, one for functions and one for local vars.
newtype LlvmEnv = LlvmEnv (LlvmEnvMap, LlvmEnvMap, LlvmVersion, DynFlags)
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
}
type LlvmEnvMap = UniqFM LlvmType
-- | Get initial Llvm environment.
initLlvmEnv :: DynFlags -> LlvmEnv
initLlvmEnv dflags = LlvmEnv (initFuncs, emptyUFM, defaultLlvmVersion, dflags)
where initFuncs = listToUFM $ [ (n, LMFunction ty) | (n, ty) <- ghcInternalFunctions dflags ]
-- | The Llvm monad. Wraps @LlvmEnv@ state as well as the @IO@ monad
newtype LlvmM a = LlvmM { runLlvmM :: LlvmEnv -> IO (a, LlvmEnv) }
instance Monad LlvmM where
return x = LlvmM $ \env -> return (x, env)
m >>= f = LlvmM $ \env -> do (x, env') <- runLlvmM m env
runLlvmM (f x) env'
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)
-- | Here we pre-initialise some functions that are used internally by GHC
-- so as to make sure they have the most general type in the case that
-- user code also uses these functions but with a different type than GHC
-- internally. (Main offender is treating return type as 'void' instead of
-- 'void *'. Fixes trac #5486.
ghcInternalFunctions :: DynFlags -> [(LMString, LlvmFunctionDecl)]
ghcInternalFunctions dflags =
[ mk "memcpy" i8Ptr [i8Ptr, i8Ptr, llvmWord dflags]
, mk "memmove" i8Ptr [i8Ptr, i8Ptr, llvmWord dflags]
, mk "memset" i8Ptr [i8Ptr, llvmWord dflags, llvmWord dflags]
, mk "newSpark" (llvmWord dflags) [i8Ptr, i8Ptr]
]
where
mk n ret args =
let n' = fsLit n
in (n', LlvmFunctionDecl n' ExternallyVisible CC_Ccc ret
FixedArgs (tysToParams args) Nothing)
-- | Clear variables from the environment.
clearVars :: LlvmEnv -> LlvmEnv
clearVars (LlvmEnv (e1, _, n, p)) = {-# SCC "llvm_env_clear" #-}
LlvmEnv (e1, emptyUFM, n, p)
-- | Insert local variables into the environment.
varInsert :: Uniquable key => key -> LlvmType -> LlvmEnv -> LlvmEnv
varInsert s t (LlvmEnv (e1, e2, n, p)) = {-# SCC "llvm_env_vinsert" #-}
LlvmEnv (e1, addToUFM e2 s t, n, p)
-- | Insert functions into the environment.
funInsert :: Uniquable key => key -> LlvmType -> LlvmEnv -> LlvmEnv
funInsert s t (LlvmEnv (e1, e2, n, p)) = {-# SCC "llvm_env_finsert" #-}
LlvmEnv (addToUFM e1 s t, e2, n, p)
-- | Lookup local variables in the environment.
varLookup :: Uniquable key => key -> LlvmEnv -> Maybe LlvmType
varLookup s (LlvmEnv (_, e2, _, _)) = {-# SCC "llvm_env_vlookup" #-}
lookupUFM e2 s
-- | Lookup functions in the environment.
funLookup :: Uniquable key => key -> LlvmEnv -> Maybe LlvmType
funLookup s (LlvmEnv (e1, _, _, _)) = {-# SCC "llvm_env_flookup" #-}
lookupUFM e1 s
-- | Get initial Llvm environment.
runLlvm :: DynFlags -> LlvmVersion -> BufHandle -> UniqSupply -> LlvmM () -> IO ()
runLlvm dflags ver out us m = do
_ <- runLlvmM m env
return ()
where env = LlvmEnv { envFunMap = emptyUFM
, envVarMap = emptyUFM
, envStackRegs = []
, envUsedVars = []
, envAliases = emptyUniqSet
, envLabelMap = []
, envVersion = ver
, envDynFlags = dflags
, envOutput = out
, envUniq = us
, envFreshMeta = 0
, envUniqMeta = emptyUFM
, envNextSection = 1
}
-- | Get environment (internal)
getEnv :: (LlvmEnv -> a) -> LlvmM a
getEnv f = LlvmM (\env -> return (f env, env))
-- | Modify environment (internal)
modifyEnv :: (LlvmEnv -> LlvmEnv) -> LlvmM ()
modifyEnv f = LlvmM (\env -> return ((), f env))
-- | Lift a stream into the LlvmM monad
liftStream :: Stream.Stream IO a x -> Stream.Stream LlvmM a x
liftStream s = Stream.Stream $ do
r <- liftIO $ Stream.runStream s
case r of
Left b -> return (Left b)
Right (a, r2) -> return (Right (a, liftStream r2))
-- | Clear variables from the environment for a subcomputation
withClearVars :: LlvmM a -> LlvmM a
withClearVars m = LlvmM $ \env -> do
(x, env') <- runLlvmM m env { envVarMap = emptyUFM, envStackRegs = [] }
return (x, env' { envVarMap = emptyUFM, envStackRegs = [] })
-- | Insert variables or functions into the environment.
varInsert, funInsert :: Uniquable key => key -> LlvmType -> LlvmM ()
varInsert s t = modifyEnv $ \env -> env { envVarMap = addToUFM (envVarMap env) s t }
funInsert s t = modifyEnv $ \env -> env { envFunMap = addToUFM (envFunMap env) s t }
-- | Lookup variables or functions in the environment.
varLookup, funLookup :: Uniquable key => key -> LlvmM (Maybe LlvmType)
varLookup s = getEnv (flip lookupUFM s . envVarMap)
funLookup s = getEnv (flip lookupUFM s . envFunMap)
-- | Set a register as allocated on the stack
markStackReg :: GlobalReg -> LlvmM ()
markStackReg r = modifyEnv $ \env -> env { envStackRegs = r : envStackRegs env }
-- | Check whether a register is allocated on the stack
checkStackReg :: GlobalReg -> LlvmM Bool
checkStackReg r = getEnv ((elem r) . envStackRegs)
-- | Allocate a new global unnamed metadata identifier
getMetaUniqueId :: LlvmM Int
getMetaUniqueId = LlvmM $ \env -> return (envFreshMeta env, env { envFreshMeta = envFreshMeta env + 1})
-- | Get the LLVM version we are generating code for
getLlvmVer :: LlvmEnv -> LlvmVersion
getLlvmVer (LlvmEnv (_, _, n, _)) = n
getLlvmVer :: LlvmM LlvmVersion
getLlvmVer = getEnv envVersion
-- | Set the LLVM version we are generating code for
setLlvmVer :: LlvmVersion -> LlvmEnv -> LlvmEnv
setLlvmVer n (LlvmEnv (e1, e2, _, p)) = LlvmEnv (e1, e2, n, p)
-- | Get the platform we are generating code for
getDynFlag :: (DynFlags -> a) -> LlvmM a
getDynFlag f = getEnv (f . envDynFlags)
-- | Get the platform we are generating code for
getLlvmPlatform :: LlvmEnv -> Platform
getLlvmPlatform (LlvmEnv (_, _, _, d)) = targetPlatform d
getLlvmPlatform :: LlvmM Platform
getLlvmPlatform = getDynFlag targetPlatform
-- | Prints the given contents to the output handle
renderLlvm :: Outp.SDoc -> LlvmM ()
renderLlvm sdoc = LlvmM $ \env -> do
-- Write to output
let doc = Outp.withPprStyleDoc (envDynFlags env) (Outp.mkCodeStyle Outp.CStyle) sdoc
Prt.bufLeftRender (envOutput env) doc
-- Dump, if requested
dumpIfSet_dyn (envDynFlags env) Opt_D_dump_llvm "LLVM Code" sdoc
return ((), env)
-- | 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 }
-- | Return all variables marked as "used" so far