module LlvmCodeGen.Base (
LlvmCmmTop, LlvmBasicBlock,
LlvmUnresData, LlvmData, UnresLabel, UnresStatic,
LlvmVersion, defaultLlvmVersion,
LlvmEnv, initLlvmEnv, clearVars, varLookup, varInsert,
funLookup, funInsert, getLlvmVer, setLlvmVer,
cmmToLlvmType, widthToLlvmFloat, widthToLlvmInt, llvmFunTy,
llvmFunSig, llvmStdFunAttrs, llvmFunAlign, llvmInfAlign,
llvmPtrBits, mkLlvmFunc, tysToParams,
strCLabel_llvm, genCmmLabelRef, genStringLabelRef
) where
#include "HsVersions.h"
import Llvm
import LlvmCodeGen.Regs
import CLabel
import CgUtils ( activeStgRegs )
import Config
import Constants
import FastString
import OldCmm
import qualified Outputable as Outp
import UniqFM
import Unique
type LlvmCmmTop = GenCmmTop [LlvmData] (Maybe CmmStatics) (ListGraph LlvmStatement)
type LlvmBasicBlock = GenBasicBlock LlvmStatement
type LlvmUnresData = (CLabel, Section, LlvmType, [UnresStatic])
type LlvmData = ([LMGlobal], [LlvmType])
type UnresLabel = CmmLit
type UnresStatic = Either UnresLabel LlvmStatic
cmmToLlvmType :: CmmType -> LlvmType
cmmToLlvmType ty | isFloatType ty = widthToLlvmFloat $ typeWidth ty
| otherwise = widthToLlvmInt $ typeWidth ty
widthToLlvmFloat :: Width -> LlvmType
widthToLlvmFloat W32 = LMFloat
widthToLlvmFloat W64 = LMDouble
widthToLlvmFloat W80 = LMFloat80
widthToLlvmFloat W128 = LMFloat128
widthToLlvmFloat w = panic $ "widthToLlvmFloat: Bad float size: " ++ show w
widthToLlvmInt :: Width -> LlvmType
widthToLlvmInt w = LMInt $ widthInBits w
llvmGhcCC :: LlvmCallConvention
llvmGhcCC | cGhcUnregisterised == "NO" = CC_Ncc 10
| otherwise = CC_Ccc
llvmFunTy :: LlvmType
llvmFunTy = LMFunction $ llvmFunSig' (fsLit "a") ExternallyVisible
llvmFunSig :: CLabel -> LlvmLinkageType -> LlvmFunctionDecl
llvmFunSig lbl link = llvmFunSig' (strCLabel_llvm lbl) link
llvmFunSig' :: LMString -> LlvmLinkageType -> LlvmFunctionDecl
llvmFunSig' lbl link
= let toParams x | isPointer x = (x, [NoAlias, NoCapture])
| otherwise = (x, [])
in LlvmFunctionDecl lbl link llvmGhcCC LMVoid FixedArgs
(map (toParams . getVarType) llvmFunArgs) llvmFunAlign
mkLlvmFunc :: CLabel -> LlvmLinkageType -> LMSection -> LlvmBlocks
-> LlvmFunction
mkLlvmFunc lbl link sec blks
= let funDec = llvmFunSig lbl link
funArgs = map (fsLit . getPlainName) llvmFunArgs
in LlvmFunction funDec funArgs llvmStdFunAttrs sec blks
llvmFunAlign :: LMAlign
llvmFunAlign = Just wORD_SIZE
llvmInfAlign :: LMAlign
llvmInfAlign = Just wORD_SIZE
llvmFunArgs :: [LlvmVar]
llvmFunArgs = map lmGlobalRegArg activeStgRegs
llvmStdFunAttrs :: [LlvmFuncAttr]
llvmStdFunAttrs = [NoUnwind]
tysToParams :: [LlvmType] -> [LlvmParameter]
tysToParams = map (\ty -> (ty, []))
llvmPtrBits :: Int
llvmPtrBits = widthInBits $ typeWidth gcWord
type LlvmVersion = Int
defaultLlvmVersion :: LlvmVersion
defaultLlvmVersion = 28
newtype LlvmEnv = LlvmEnv (LlvmEnvMap, LlvmEnvMap, LlvmVersion)
type LlvmEnvMap = UniqFM LlvmType
initLlvmEnv :: LlvmEnv
initLlvmEnv = LlvmEnv (emptyUFM, emptyUFM, defaultLlvmVersion)
clearVars :: LlvmEnv -> LlvmEnv
clearVars (LlvmEnv (e1, _, n)) = LlvmEnv (e1, emptyUFM, n)
varInsert, funInsert :: Uniquable key => key -> LlvmType -> LlvmEnv -> LlvmEnv
varInsert s t (LlvmEnv (e1, e2, n)) = LlvmEnv (e1, addToUFM e2 s t, n)
funInsert s t (LlvmEnv (e1, e2, n)) = LlvmEnv (addToUFM e1 s t, e2, n)
varLookup, funLookup :: Uniquable key => key -> LlvmEnv -> Maybe LlvmType
varLookup s (LlvmEnv (_, e2, _)) = lookupUFM e2 s
funLookup s (LlvmEnv (e1, _, _)) = lookupUFM e1 s
getLlvmVer :: LlvmEnv -> LlvmVersion
getLlvmVer (LlvmEnv (_, _, n)) = n
setLlvmVer :: LlvmVersion -> LlvmEnv -> LlvmEnv
setLlvmVer n (LlvmEnv (e1, e2, _)) = LlvmEnv (e1, e2, n)
strCLabel_llvm :: CLabel -> LMString
strCLabel_llvm l = (fsLit . show . llvmSDoc . pprCLabel) l
genCmmLabelRef :: CLabel -> LMGlobal
genCmmLabelRef = genStringLabelRef . strCLabel_llvm
genStringLabelRef :: LMString -> LMGlobal
genStringLabelRef cl
= let ty = LMPointer $ LMArray 0 llvmWord
in (LMGlobalVar cl ty External Nothing Nothing False, Nothing)
panic :: String -> a
panic s = Outp.panic $ "LlvmCodeGen.Base." ++ s