module LlvmCodeGen.Base (
LlvmCmmDecl, LlvmBasicBlock,
LiveGlobalRegs,
LlvmUnresData, LlvmData, UnresLabel, UnresStatic,
LlvmVersion, llvmVersionSupported, parseLlvmVersion,
supportedLlvmVersionMin, supportedLlvmVersionMax,
llvmVersionStr, llvmVersionList,
LlvmM,
runLlvm, liftStream, withClearVars, varLookup, varInsert,
markStackReg, checkStackReg,
funLookup, funInsert, getLlvmVer, getDynFlags, getDynFlag, getLlvmPlatform,
dumpIfSetLlvm, renderLlvm, markUsedVar, getUsedVars,
ghcInternalFunctions,
getMetaUniqueId,
setUniqMeta, getUniqMeta,
cmmToLlvmType, widthToLlvmFloat, widthToLlvmInt, llvmFunTy,
llvmFunSig, llvmFunArgs, llvmStdFunAttrs, llvmFunAlign, llvmInfAlign,
llvmPtrBits, tysToParams, llvmFunSection,
strCLabel_llvm, strDisplayName_llvm, strProcedureName_llvm,
getGlobalPtr, generateExternDecls,
aliasify, llvmDefLabel,
padLiveArgs, isFPR
) where
#include "HsVersions.h"
#include "ghcautoconf.h"
import GhcPrelude
import Llvm
import LlvmCodeGen.Regs
import Panic
import PprCmm ()
import CLabel
import GHC.Platform.Regs ( activeStgRegs, globalRegMaybe )
import DynFlags
import FastString
import Cmm hiding ( succ )
import CmmUtils (regsOverlap)
import Outputable as Outp
import GHC.Platform
import UniqFM
import Unique
import BufWrite ( BufHandle )
import UniqSet
import UniqSupply
import ErrUtils
import qualified Stream
import Data.Maybe (fromJust)
import Control.Monad (ap)
import Data.Char (isDigit)
import Data.List (sortBy, groupBy, intercalate)
import Data.Ord (comparing)
import qualified Data.List.NonEmpty as NE
type LlvmCmmDecl = GenCmmDecl [LlvmData] (Maybe CmmStatics) (ListGraph LlvmStatement)
type LlvmBasicBlock = GenBasicBlock LlvmStatement
type LiveGlobalRegs = [GlobalReg]
type LlvmUnresData = (CLabel, Section, LlvmType, [UnresStatic])
type LlvmData = ([LMGlobal], [LlvmType])
type UnresLabel = CmmLit
type UnresStatic = Either UnresLabel LlvmStatic
cmmToLlvmType :: CmmType -> LlvmType
cmmToLlvmType ty | isVecType ty = LMVector (vecLength ty) (cmmToLlvmType (vecElemType ty))
| isFloatType ty = widthToLlvmFloat $ typeWidth ty
| otherwise = widthToLlvmInt $ typeWidth ty
widthToLlvmFloat :: Width -> LlvmType
widthToLlvmFloat W32 = LMFloat
widthToLlvmFloat W64 = LMDouble
widthToLlvmFloat W128 = LMFloat128
widthToLlvmFloat w = panic $ "widthToLlvmFloat: Bad float size: " ++ show w
widthToLlvmInt :: Width -> LlvmType
widthToLlvmInt w = LMInt $ widthInBits w
llvmGhcCC :: DynFlags -> LlvmCallConvention
llvmGhcCC dflags
| platformUnregisterised (targetPlatform dflags) = CC_Ccc
| otherwise = CC_Ghc
llvmFunTy :: LiveGlobalRegs -> LlvmM LlvmType
llvmFunTy live = return . LMFunction =<< llvmFunSig' live (fsLit "a") ExternallyVisible
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)
llvmFunAlign :: DynFlags -> LMAlign
llvmFunAlign dflags = Just (wORD_SIZE dflags)
llvmInfAlign :: DynFlags -> LMAlign
llvmInfAlign dflags = Just (wORD_SIZE dflags)
llvmFunSection :: DynFlags -> LMString -> LMSection
llvmFunSection dflags lbl
| gopt Opt_SplitSections dflags = Just (concatFS [fsLit ".text.", lbl])
| otherwise = Nothing
llvmFunArgs :: DynFlags -> LiveGlobalRegs -> [LlvmVar]
llvmFunArgs dflags live =
map (lmGlobalRegArg dflags) (filter isPassed allRegs)
where allRegs = activeStgRegs (targetPlatform dflags)
paddingRegs = padLiveArgs dflags live
isLive r = r `elem` alwaysLive
|| r `elem` live
|| r `elem` paddingRegs
isPassed r = not (isFPR r) || isLive r
isFPR :: GlobalReg -> Bool
isFPR (FloatReg _) = True
isFPR (DoubleReg _) = True
isFPR (XmmReg _) = True
isFPR (YmmReg _) = True
isFPR (ZmmReg _) = True
isFPR _ = False
padLiveArgs :: DynFlags -> LiveGlobalRegs -> LiveGlobalRegs
padLiveArgs dflags live =
if platformUnregisterised platform
then []
else padded
where
platform = targetPlatform dflags
fprLive = filter isFPR live
classes = groupBy sharesClass fprLive
sharesClass a b = regsOverlap dflags (norm a) (norm b)
norm x = CmmGlobal ((fpr_ctor x) 1)
padded = concatMap padClass classes
padClass rs = go sortedRs [1..]
where
sortedRs = sortBy (comparing fpr_num) rs
maxr = last sortedRs
ctor = fpr_ctor maxr
go [] _ = []
go (c1:c2:_) _
| fpr_num c1 == fpr_num c2
, Just real <- globalRegMaybe platform c1
= sorryDoc "LLVM code generator" $
text "Found two different Cmm registers (" <> ppr c1 <> text "," <> ppr c2 <>
text ") both alive AND mapped to the same real register: " <> ppr real <>
text ". This isn't currently supported by the LLVM backend."
go (c:cs) (f:fs)
| fpr_num c == f = go cs fs
| otherwise = ctor f : go (c:cs) fs
go _ _ = undefined
fpr_ctor :: GlobalReg -> Int -> GlobalReg
fpr_ctor (FloatReg _) = FloatReg
fpr_ctor (DoubleReg _) = DoubleReg
fpr_ctor (XmmReg _) = XmmReg
fpr_ctor (YmmReg _) = YmmReg
fpr_ctor (ZmmReg _) = ZmmReg
fpr_ctor _ = error "fpr_ctor expected only FPR regs"
fpr_num :: GlobalReg -> Int
fpr_num (FloatReg i) = i
fpr_num (DoubleReg i) = i
fpr_num (XmmReg i) = i
fpr_num (YmmReg i) = i
fpr_num (ZmmReg i) = i
fpr_num _ = error "fpr_num expected only FPR regs"
llvmStdFunAttrs :: [LlvmFuncAttr]
llvmStdFunAttrs = [NoUnwind]
tysToParams :: [LlvmType] -> [LlvmParameter]
tysToParams = map (\ty -> (ty, []))
llvmPtrBits :: DynFlags -> Int
llvmPtrBits dflags = widthInBits $ typeWidth $ gcWord dflags
newtype LlvmVersion = LlvmVersion { llvmVersionNE :: NE.NonEmpty Int }
deriving (Eq, Ord)
parseLlvmVersion :: String -> Maybe LlvmVersion
parseLlvmVersion =
fmap LlvmVersion . NE.nonEmpty . go [] . dropWhile (not . isDigit)
where
go vs s
| null ver_str
= reverse vs
| '.' : rest' <- rest
= go (read ver_str : vs) rest'
| otherwise
= reverse (read ver_str : vs)
where
(ver_str, rest) = span isDigit s
supportedLlvmVersionMin, supportedLlvmVersionMax :: LlvmVersion
supportedLlvmVersionMin = LlvmVersion (sUPPORTED_LLVM_VERSION_MIN NE.:| [])
supportedLlvmVersionMax = LlvmVersion (sUPPORTED_LLVM_VERSION_MAX NE.:| [])
llvmVersionSupported :: LlvmVersion -> Bool
llvmVersionSupported v =
v > supportedLlvmVersionMin && v <= supportedLlvmVersionMax
llvmVersionStr :: LlvmVersion -> String
llvmVersionStr = intercalate "." . map show . llvmVersionList
llvmVersionList :: LlvmVersion -> [Int]
llvmVersionList = NE.toList . llvmVersionNE
data LlvmEnv = LlvmEnv
{ envVersion :: LlvmVersion
, envDynFlags :: DynFlags
, envOutput :: BufHandle
, envMask :: !Char
, envFreshMeta :: MetaId
, envUniqMeta :: UniqFM MetaId
, envFunMap :: LlvmEnvMap
, envAliases :: UniqSet LMString
, envUsedVars :: [LlvmVar]
, envVarMap :: LlvmEnvMap
, envStackRegs :: [GlobalReg]
}
type LlvmEnvMap = UniqFM LlvmType
newtype LlvmM a = LlvmM { runLlvmM :: LlvmEnv -> IO (a, LlvmEnv) }
deriving (Functor)
instance Applicative LlvmM where
pure x = LlvmM $ \env -> return (x, env)
(<*>) = ap
instance Monad LlvmM where
m >>= f = LlvmM $ \env -> do (x, env') <- runLlvmM m env
runLlvmM (f x) env'
instance HasDynFlags LlvmM where
getDynFlags = LlvmM $ \env -> return (envDynFlags env, env)
instance MonadUnique LlvmM where
getUniqueSupplyM = do
mask <- getEnv envMask
liftIO $! mkSplitUniqSupply mask
getUniqueM = do
mask <- getEnv envMask
liftIO $! uniqFromMask mask
liftIO :: IO a -> LlvmM a
liftIO m = LlvmM $ \env -> do x <- m
return (x, env)
runLlvm :: DynFlags -> LlvmVersion -> BufHandle -> LlvmM a -> IO a
runLlvm dflags ver out m = do
(a, _) <- runLlvmM m env
return a
where env = LlvmEnv { envFunMap = emptyUFM
, envVarMap = emptyUFM
, envStackRegs = []
, envUsedVars = []
, envAliases = emptyUniqSet
, envVersion = ver
, envDynFlags = dflags
, envOutput = out
, envMask = 'n'
, envFreshMeta = MetaId 0
, envUniqMeta = emptyUFM
}
getEnv :: (LlvmEnv -> a) -> LlvmM a
getEnv f = LlvmM (\env -> return (f env, env))
modifyEnv :: (LlvmEnv -> LlvmEnv) -> LlvmM ()
modifyEnv f = LlvmM (\env -> return ((), f env))
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))
withClearVars :: LlvmM a -> LlvmM a
withClearVars m = LlvmM $ \env -> do
(x, env') <- runLlvmM m env { envVarMap = emptyUFM, envStackRegs = [] }
return (x, env' { envVarMap = emptyUFM, envStackRegs = [] })
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 }
varLookup, funLookup :: Uniquable key => key -> LlvmM (Maybe LlvmType)
varLookup s = getEnv (flip lookupUFM s . envVarMap)
funLookup s = getEnv (flip lookupUFM s . envFunMap)
markStackReg :: GlobalReg -> LlvmM ()
markStackReg r = modifyEnv $ \env -> env { envStackRegs = r : envStackRegs env }
checkStackReg :: GlobalReg -> LlvmM Bool
checkStackReg r = getEnv ((elem r) . envStackRegs)
getMetaUniqueId :: LlvmM MetaId
getMetaUniqueId = LlvmM $ \env ->
return (envFreshMeta env, env { envFreshMeta = succ $ envFreshMeta env })
getLlvmVer :: LlvmM LlvmVersion
getLlvmVer = getEnv envVersion
getDynFlag :: (DynFlags -> a) -> LlvmM a
getDynFlag f = getEnv (f . envDynFlags)
getLlvmPlatform :: LlvmM Platform
getLlvmPlatform = getDynFlag targetPlatform
dumpIfSetLlvm :: DumpFlag -> String -> Outp.SDoc -> LlvmM ()
dumpIfSetLlvm flag hdr doc = do
dflags <- getDynFlags
liftIO $ dumpIfSet_dyn dflags flag hdr doc
renderLlvm :: Outp.SDoc -> LlvmM ()
renderLlvm sdoc = do
dflags <- getDynFlags
out <- getEnv envOutput
liftIO $ Outp.bufLeftRenderSDoc dflags out
(Outp.mkCodeStyle Outp.CStyle) sdoc
dumpIfSetLlvm Opt_D_dump_llvm "LLVM Code" sdoc
return ()
markUsedVar :: LlvmVar -> LlvmM ()
markUsedVar v = modifyEnv $ \env -> env { envUsedVars = v : envUsedVars env }
getUsedVars :: LlvmM [LlvmVar]
getUsedVars = getEnv envUsedVars
saveAlias :: LMString -> LlvmM ()
saveAlias lbl = modifyEnv $ \env -> env { envAliases = addOneToUniqSet (envAliases env) lbl }
setUniqMeta :: Unique -> MetaId -> LlvmM ()
setUniqMeta f m = modifyEnv $ \env -> env { envUniqMeta = addToUFM (envUniqMeta env) f m }
getUniqMeta :: Unique -> LlvmM (Maybe MetaId)
getUniqMeta s = getEnv (flip lookupUFM s . envUniqMeta)
ghcInternalFunctions :: LlvmM ()
ghcInternalFunctions = do
dflags <- getDynFlags
let w = llvmWord dflags
cint = LMInt $ widthInBits $ cIntWidth dflags
mk "memcmp" cint [i8Ptr, i8Ptr, w]
mk "memcpy" i8Ptr [i8Ptr, i8Ptr, w]
mk "memmove" i8Ptr [i8Ptr, i8Ptr, w]
mk "memset" i8Ptr [i8Ptr, w, w]
mk "newSpark" w [i8Ptr, i8Ptr]
where
mk n ret args = do
let n' = fsLit n
decl = LlvmFunctionDecl n' ExternallyVisible CC_Ccc ret
FixedArgs (tysToParams args) Nothing
renderLlvm $ ppLlvmFunctionDecl decl
funInsert n' (LMFunction decl)
strCLabel_llvm :: CLabel -> LlvmM LMString
strCLabel_llvm lbl = do
dflags <- getDynFlags
let sdoc = pprCLabel dflags lbl
str = Outp.renderWithStyle dflags sdoc (Outp.mkCodeStyle Outp.CStyle)
return (fsLit str)
strDisplayName_llvm :: CLabel -> LlvmM LMString
strDisplayName_llvm lbl = do
dflags <- getDynFlags
let sdoc = pprCLabel dflags lbl
depth = Outp.PartWay 1
style = Outp.mkUserStyle dflags Outp.reallyAlwaysQualify depth
str = Outp.renderWithStyle dflags sdoc style
return (fsLit (dropInfoSuffix str))
dropInfoSuffix :: String -> String
dropInfoSuffix = go
where go "_info" = []
go "_static_info" = []
go "_con_info" = []
go (x:xs) = x:go xs
go [] = []
strProcedureName_llvm :: CLabel -> LlvmM LMString
strProcedureName_llvm lbl = do
dflags <- getDynFlags
let sdoc = pprCLabel dflags lbl
depth = Outp.PartWay 1
style = Outp.mkUserStyle dflags Outp.neverQualify depth
str = Outp.renderWithStyle dflags sdoc style
return (fsLit str)
getGlobalPtr :: LMString -> LlvmM LlvmVar
getGlobalPtr llvmLbl = do
m_ty <- funLookup llvmLbl
let mkGlbVar lbl ty = LMGlobalVar lbl (LMPointer ty) Private Nothing Nothing
case m_ty of
Just ty -> do
if llvmLbl `elem` (map fsLit ["newSpark", "memmove", "memcpy", "memcmp", "memset"])
then return $ mkGlbVar (llvmLbl) ty Global
else return $ mkGlbVar (llvmDefLabel llvmLbl) ty Global
Nothing -> do
saveAlias llvmLbl
return $ mkGlbVar llvmLbl i8 Alias
llvmDefLabel :: LMString -> LMString
llvmDefLabel = (`appendFS` fsLit "$def")
generateExternDecls :: LlvmM ([LMGlobal], [LlvmType])
generateExternDecls = do
delayed <- fmap nonDetEltsUniqSet $ getEnv envAliases
defss <- flip mapM delayed $ \lbl -> do
m_ty <- funLookup lbl
case m_ty of
Just _ -> return []
Nothing ->
let var = LMGlobalVar lbl i8Ptr External Nothing Nothing Global
in return [LMGlobal var Nothing]
modifyEnv $ \env -> env { envAliases = emptyUniqSet }
return (concat defss, [])
aliasify :: LMGlobal -> LlvmM [LMGlobal]
aliasify (LMGlobal (LMGlobalVar lbl ty@LMAlias{} link sect align Alias)
(Just orig)) = do
let defLbl = llvmDefLabel lbl
LMStaticPointer (LMGlobalVar origLbl _ oLnk Nothing Nothing Alias) = orig
defOrigLbl = llvmDefLabel origLbl
orig' = LMStaticPointer (LMGlobalVar origLbl i8Ptr oLnk Nothing Nothing Alias)
origType <- funLookup origLbl
let defOrig = LMBitc (LMStaticPointer (LMGlobalVar defOrigLbl
(pLift $ fromJust origType) oLnk
Nothing Nothing Alias))
(pLift ty)
pure [ LMGlobal (LMGlobalVar defLbl ty link sect align Alias) (Just defOrig)
, LMGlobal (LMGlobalVar lbl i8Ptr link sect align Alias) (Just orig')
]
aliasify (LMGlobal var val) = do
let LMGlobalVar lbl ty link sect align const = var
defLbl = llvmDefLabel lbl
defVar = LMGlobalVar defLbl ty Internal sect align const
defPtrVar = LMGlobalVar defLbl (LMPointer ty) link Nothing Nothing const
aliasVar = LMGlobalVar lbl i8Ptr link Nothing Nothing Alias
aliasVal = LMBitc (LMStaticPointer defPtrVar) i8Ptr
markUsedVar defVar
return [ LMGlobal defVar val
, LMGlobal aliasVar (Just aliasVal)
]