Base.hs 8.6 KB
Newer Older
1 2 3 4 5 6 7 8
-- ----------------------------------------------------------------------------
-- | Base LLVM Code Generation module
--
-- Contains functions useful through out the code generator.
--

module LlvmCodeGen.Base (

Simon Peyton Jones's avatar
Simon Peyton Jones committed
9
        LlvmCmmDecl, LlvmBasicBlock,
10 11
        LlvmUnresData, LlvmData, UnresLabel, UnresStatic,

12 13
        LlvmVersion, defaultLlvmVersion, minSupportLlvmVersion,
        maxSupportLlvmVersion,
14

15
        LlvmEnv, initLlvmEnv, clearVars, varLookup, varInsert,
16
        funLookup, funInsert, getLlvmVer, setLlvmVer, getLlvmPlatform,
17
        getDflags, ghcInternalFunctions,
18 19

        cmmToLlvmType, widthToLlvmFloat, widthToLlvmInt, llvmFunTy,
dterei's avatar
dterei committed
20
        llvmFunSig, llvmStdFunAttrs, llvmFunAlign, llvmInfAlign,
21
        llvmPtrBits, mkLlvmFunc, tysToParams,
22

dterei's avatar
dterei committed
23
        strCLabel_llvm, genCmmLabelRef, genStringLabelRef
24 25 26 27 28 29 30 31 32

    ) where

#include "HsVersions.h"

import Llvm
import LlvmCodeGen.Regs

import CLabel
33 34
import CgUtils ( activeStgRegs )
import Constants
35
import DynFlags
36
import FastString
37
import OldCmm
38
import qualified Outputable as Outp
39
import Platform
40
import UniqFM
41
import Unique
42 43 44 45 46

-- ----------------------------------------------------------------------------
-- * Some Data Types
--

Simon Peyton Jones's avatar
Simon Peyton Jones committed
47
type LlvmCmmDecl = GenCmmDecl [LlvmData] (Maybe CmmStatics) (ListGraph LlvmStatement)
48 49 50
type LlvmBasicBlock = GenBasicBlock LlvmStatement

-- | Unresolved code.
dterei's avatar
dterei committed
51
-- Of the form: (data label, data type, unresolved data)
52
type LlvmUnresData = (CLabel, Section, LlvmType, [UnresStatic])
53 54 55 56 57 58 59 60

-- | Top level LLVM Data (globals and type aliases)
type LlvmData = ([LMGlobal], [LlvmType])

-- | An unresolved Label.
--
-- Labels are unresolved when we haven't yet determined if they are defined in
-- the module we are currently compiling, or an external one.
dterei's avatar
dterei committed
61
type UnresLabel  = CmmLit
62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85
type UnresStatic = Either UnresLabel LlvmStatic

-- ----------------------------------------------------------------------------
-- * Type translations
--

-- | Translate a basic CmmType to an LlvmType.
cmmToLlvmType :: CmmType -> LlvmType
cmmToLlvmType ty | isFloatType ty = widthToLlvmFloat $ typeWidth ty
                 | otherwise      = widthToLlvmInt   $ typeWidth ty

-- | Translate a Cmm Float Width to a LlvmType.
widthToLlvmFloat :: Width -> LlvmType
widthToLlvmFloat W32  = LMFloat
widthToLlvmFloat W64  = LMDouble
widthToLlvmFloat W80  = LMFloat80
widthToLlvmFloat W128 = LMFloat128
widthToLlvmFloat w    = panic $ "widthToLlvmFloat: Bad float size: " ++ show w

-- | Translate a Cmm Bit Width to a LlvmType.
widthToLlvmInt :: Width -> LlvmType
widthToLlvmInt w = LMInt $ widthInBits w

-- | GHC Call Convention for LLVM
86 87 88 89
llvmGhcCC :: DynFlags -> LlvmCallConvention
llvmGhcCC dflags
 | platformUnregisterised (targetPlatform dflags) = CC_Ncc 10
 | otherwise                                      = CC_Ccc
90 91

-- | Llvm Function type for Cmm function
92 93
llvmFunTy :: DynFlags -> LlvmType
llvmFunTy dflags = LMFunction $ llvmFunSig' dflags (fsLit "a") ExternallyVisible
94 95

-- | Llvm Function signature
96
llvmFunSig :: LlvmEnv -> CLabel -> LlvmLinkageType -> LlvmFunctionDecl
97 98
llvmFunSig env lbl link
    = llvmFunSig' (getDflags env) (strCLabel_llvm env lbl) link
99

100 101
llvmFunSig' :: DynFlags -> LMString -> LlvmLinkageType -> LlvmFunctionDecl
llvmFunSig' dflags lbl link
102 103
  = let toParams x | isPointer x = (x, [NoAlias, NoCapture])
                   | otherwise   = (x, [])
104
    in LlvmFunctionDecl lbl link (llvmGhcCC dflags) LMVoid FixedArgs
105
                        (map (toParams . getVarType) llvmFunArgs) llvmFunAlign
106 107

-- | Create a Haskell function in LLVM.
108
mkLlvmFunc :: LlvmEnv -> CLabel -> LlvmLinkageType -> LMSection -> LlvmBlocks
109
           -> LlvmFunction
110 111
mkLlvmFunc env lbl link sec blks
  = let funDec = llvmFunSig env lbl link
112 113
        funArgs = map (fsLit . getPlainName) llvmFunArgs
    in LlvmFunction funDec funArgs llvmStdFunAttrs sec blks
dterei's avatar
dterei committed
114 115 116

-- | Alignment to use for functions
llvmFunAlign :: LMAlign
117
llvmFunAlign = Just wORD_SIZE
dterei's avatar
dterei committed
118 119 120

-- | Alignment to use for into tables
llvmInfAlign :: LMAlign
121
llvmInfAlign = Just wORD_SIZE
122 123 124 125 126 127 128 129 130

-- | A Function's arguments
llvmFunArgs :: [LlvmVar]
llvmFunArgs = map lmGlobalRegArg activeStgRegs

-- | Llvm standard fun attributes
llvmStdFunAttrs :: [LlvmFuncAttr]
llvmStdFunAttrs = [NoUnwind]

131 132 133 134 135
-- | Convert a list of types to a list of function parameters
-- (each with no parameter attributes)
tysToParams :: [LlvmType] -> [LlvmParameter]
tysToParams = map (\ty -> (ty, []))

136 137 138 139
-- | Pointer width
llvmPtrBits :: Int
llvmPtrBits = widthInBits $ typeWidth gcWord

140 141 142 143 144 145 146 147 148
-- ----------------------------------------------------------------------------
-- * Llvm Version
--

-- | LLVM Version Number
type LlvmVersion = Int

-- | The LLVM Version we assume if we don't know
defaultLlvmVersion :: LlvmVersion
149 150 151 152 153 154 155
defaultLlvmVersion = 30

minSupportLlvmVersion :: LlvmVersion
minSupportLlvmVersion = 28

maxSupportLlvmVersion :: LlvmVersion
maxSupportLlvmVersion = 31
156 157 158 159 160 161

-- ----------------------------------------------------------------------------
-- * Environment Handling
--

-- two maps, one for functions and one for local vars.
162 163
newtype LlvmEnv = LlvmEnv (LlvmEnvMap, LlvmEnvMap, LlvmVersion, DynFlags)

164
type LlvmEnvMap = UniqFM LlvmType
165 166

-- | Get initial Llvm environment.
167 168
initLlvmEnv :: DynFlags -> LlvmEnv
initLlvmEnv dflags = LlvmEnv (initFuncs, emptyUFM, defaultLlvmVersion, dflags)
dterei's avatar
dterei committed
169 170 171 172 173 174 175 176 177 178 179 180 181 182 183 184 185 186 187
    where initFuncs = listToUFM $ [ (n, LMFunction ty) | (n, ty) <- ghcInternalFunctions ]

-- | 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 :: [(LMString, LlvmFunctionDecl)]
ghcInternalFunctions =
    [ mk "memcpy" i8Ptr [i8Ptr, i8Ptr, llvmWord]
    , mk "memmove" i8Ptr [i8Ptr, i8Ptr, llvmWord]
    , mk "memset" i8Ptr [i8Ptr, llvmWord, llvmWord]
    , mk "newSpark" llvmWord [i8Ptr, i8Ptr]
    ]
  where
    mk n ret args =
        let n' = fsLit n
        in (n', LlvmFunctionDecl n' ExternallyVisible CC_Ccc ret
                                 FixedArgs (tysToParams args) Nothing)
188 189 190

-- | Clear variables from the environment.
clearVars :: LlvmEnv -> LlvmEnv
dterei's avatar
dterei committed
191 192
clearVars (LlvmEnv (e1, _, n, p)) = {-# SCC "llvm_env_clear" #-}
    LlvmEnv (e1, emptyUFM, n, p)
193

dterei's avatar
dterei committed
194
-- | Insert local variables into the environment.
dterei's avatar
dterei committed
195 196 197 198
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)

dterei's avatar
dterei committed
199
-- | Insert functions into the environment.
dterei's avatar
dterei committed
200 201 202
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)
203

dterei's avatar
dterei committed
204
-- | Lookup local variables in the environment.
dterei's avatar
dterei committed
205 206 207 208
varLookup :: Uniquable key => key -> LlvmEnv -> Maybe LlvmType
varLookup s (LlvmEnv (_, e2, _, _)) = {-# SCC "llvm_env_vlookup" #-}
    lookupUFM e2 s

dterei's avatar
dterei committed
209
-- | Lookup functions in the environment.
dterei's avatar
dterei committed
210 211 212
funLookup :: Uniquable key => key -> LlvmEnv -> Maybe LlvmType
funLookup s (LlvmEnv (e1, _, _, _)) = {-# SCC "llvm_env_flookup" #-}
    lookupUFM e1 s
213 214 215

-- | Get the LLVM version we are generating code for
getLlvmVer :: LlvmEnv -> LlvmVersion
216
getLlvmVer (LlvmEnv (_, _, n, _)) = n
217

218 219
-- | Set the LLVM version we are generating code for
setLlvmVer :: LlvmVersion -> LlvmEnv -> LlvmEnv
220 221 222 223
setLlvmVer n (LlvmEnv (e1, e2, _, p)) = LlvmEnv (e1, e2, n, p)

-- | Get the platform we are generating code for
getLlvmPlatform :: LlvmEnv -> Platform
224 225 226 227 228
getLlvmPlatform (LlvmEnv (_, _, _, d)) = targetPlatform d

-- | Get the DynFlags for this compilation pass
getDflags :: LlvmEnv -> DynFlags
getDflags (LlvmEnv (_, _, _, d)) = d
229 230 231 232 233 234

-- ----------------------------------------------------------------------------
-- * Label handling
--

-- | Pretty print a 'CLabel'.
235
strCLabel_llvm :: LlvmEnv -> CLabel -> LMString
dterei's avatar
dterei committed
236
strCLabel_llvm env l = {-# SCC "llvm_strCLabel" #-}
237 238 239 240
    (fsLit . toString . pprCLabel (getLlvmPlatform env)) l
    where dflags = getDflags env
          style = Outp.mkCodeStyle Outp.CStyle
          toString doc = Outp.renderWithStyle dflags doc style
241 242

-- | Create an external definition for a 'CLabel' defined in another module.
243 244
genCmmLabelRef :: LlvmEnv -> CLabel -> LMGlobal
genCmmLabelRef env = genStringLabelRef . strCLabel_llvm env
245 246 247

-- | As above ('genCmmLabelRef') but taking a 'LMString', not 'CLabel'.
genStringLabelRef :: LMString -> LMGlobal
dterei's avatar
dterei committed
248 249
genStringLabelRef cl
  = let ty = LMPointer $ LMArray 0 llvmWord
250
    in (LMGlobalVar cl ty External Nothing Nothing False, Nothing)
251 252 253 254 255 256 257 258 259

-- ----------------------------------------------------------------------------
-- * Misc
--

-- | Error function
panic :: String -> a
panic s = Outp.panic $ "LlvmCodeGen.Base." ++ s