module GHC.CmmToLlvm.Base (
LlvmCmmDecl, LlvmBasicBlock,
LiveGlobalRegs,
LlvmUnresData, LlvmData, UnresLabel, UnresStatic,
LlvmVersion, supportedLlvmVersion, llvmVersionSupported, parseLlvmVersion,
llvmVersionStr, llvmVersionList,
LlvmM,
runLlvm, liftStream, withClearVars, varLookup, varInsert,
markStackReg, checkStackReg,
funLookup, funInsert, getLlvmVer, getDynFlags,
dumpIfSetLlvm, renderLlvm, markUsedVar, getUsedVars,
ghcInternalFunctions, getPlatform, getLlvmOpts,
getMetaUniqueId,
setUniqMeta, getUniqMeta,
cmmToLlvmType, widthToLlvmFloat, widthToLlvmInt, llvmFunTy,
llvmFunSig, llvmFunArgs, llvmStdFunAttrs, llvmFunAlign, llvmInfAlign,
llvmPtrBits, tysToParams, llvmFunSection, padLiveArgs, isFPR,
strCLabel_llvm,
getGlobalPtr, generateExternDecls,
aliasify, llvmDefLabel
) where
#include "HsVersions.h"
#include "ghcautoconf.h"
import GHC.Prelude
import GHC.Utils.Panic
import GHC.Llvm
import GHC.CmmToLlvm.Regs
import GHC.Cmm.CLabel
import GHC.Cmm.Ppr.Expr ()
import GHC.Platform.Regs ( activeStgRegs, globalRegMaybe )
import GHC.Driver.Session
import GHC.Data.FastString
import GHC.Cmm hiding ( succ )
import GHC.Cmm.Utils (regsOverlap)
import GHC.Utils.Outputable as Outp
import GHC.Platform
import GHC.Types.Unique.FM
import GHC.Types.Unique
import GHC.Utils.BufHandle ( BufHandle )
import GHC.Types.Unique.Set
import GHC.Types.Unique.Supply
import GHC.Utils.Error
import qualified GHC.Data.Stream as 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 RawCmmStatics) (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 :: Platform -> LlvmCallConvention
llvmGhcCC platform
| platformUnregisterised platform = 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, [])
platform <- getPlatform
return $ LlvmFunctionDecl lbl link (llvmGhcCC platform) LMVoid FixedArgs
(map (toParams . getVarType) (llvmFunArgs platform live))
(llvmFunAlign platform)
llvmFunAlign :: Platform -> LMAlign
llvmFunAlign platform = Just (platformWordSizeInBytes platform)
llvmInfAlign :: Platform -> LMAlign
llvmInfAlign platform = Just (platformWordSizeInBytes platform)
llvmFunSection :: LlvmOpts -> LMString -> LMSection
llvmFunSection opts lbl
| llvmOptsSplitSections opts = Just (concatFS [fsLit ".text.", lbl])
| otherwise = Nothing
llvmFunArgs :: Platform -> LiveGlobalRegs -> [LlvmVar]
llvmFunArgs platform live =
map (lmGlobalRegArg platform) (filter isPassed allRegs)
where allRegs = activeStgRegs platform
paddingRegs = padLiveArgs platform 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 :: Platform -> LiveGlobalRegs -> LiveGlobalRegs
padLiveArgs platform live =
if platformUnregisterised platform
then []
else padded
where
fprLive = filter isFPR live
classes = groupBy sharesClass fprLive
sharesClass a b = regsOverlap platform (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 :: Platform -> Int
llvmPtrBits platform = widthInBits $ typeWidth $ gcWord platform
newtype LlvmVersion = LlvmVersion { llvmVersionNE :: NE.NonEmpty Int }
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
supportedLlvmVersion :: LlvmVersion
supportedLlvmVersion = LlvmVersion (sUPPORTED_LLVM_VERSION NE.:| [])
llvmVersionSupported :: LlvmVersion -> Bool
llvmVersionSupported (LlvmVersion v) = NE.head v == sUPPORTED_LLVM_VERSION
llvmVersionStr :: LlvmVersion -> String
llvmVersionStr = intercalate "." . map show . llvmVersionList
llvmVersionList :: LlvmVersion -> [Int]
llvmVersionList = NE.toList . llvmVersionNE
data LlvmEnv = LlvmEnv
{ envVersion :: LlvmVersion
, envOpts :: LlvmOpts
, envDynFlags :: DynFlags
, envOutput :: BufHandle
, envMask :: !Char
, envFreshMeta :: MetaId
, envUniqMeta :: UniqFM Unique MetaId
, envFunMap :: LlvmEnvMap
, envAliases :: UniqSet LMString
, envUsedVars :: [LlvmVar]
, envVarMap :: LlvmEnvMap
, envStackRegs :: [GlobalReg]
}
type LlvmEnvMap = UniqFM Unique 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)
getPlatform :: LlvmM Platform
getPlatform = llvmOptsPlatform <$> getLlvmOpts
getLlvmOpts :: LlvmM LlvmOpts
getLlvmOpts = LlvmM $ \env -> return (envOpts 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
, envOpts = initLlvmOpts dflags
, 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) (getUnique s) t }
funInsert s t = modifyEnv $ \env -> env { envFunMap = addToUFM (envFunMap env) (getUnique s) t }
varLookup, funLookup :: Uniquable key => key -> LlvmM (Maybe LlvmType)
varLookup s = getEnv (flip lookupUFM (getUnique s) . envVarMap)
funLookup s = getEnv (flip lookupUFM (getUnique 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
dumpIfSetLlvm :: DumpFlag -> String -> DumpFormat -> Outp.SDoc -> LlvmM ()
dumpIfSetLlvm flag hdr fmt doc = do
dflags <- getDynFlags
liftIO $ dumpIfSet_dyn dflags flag hdr fmt doc
renderLlvm :: Outp.SDoc -> LlvmM ()
renderLlvm sdoc = do
dflags <- getDynFlags
out <- getEnv envOutput
let ctx = initSDocContext dflags (Outp.mkCodeStyle Outp.CStyle)
liftIO $ Outp.bufLeftRenderSDoc ctx out sdoc
dumpIfSetLlvm Opt_D_dump_llvm "LLVM Code" FormatLLVM 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
platform <- getPlatform
let w = llvmWord platform
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' = llvmDefLabel $ 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
(initSDocContext dflags (Outp.mkCodeStyle Outp.CStyle))
sdoc
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 -> 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)
]