compiler/llvmGen/LlvmCodeGen/Base.hs

   1 -- ----------------------------------------------------------------------------
   2 -- | Base LLVM Code Generation module
   3 --
   4 -- Contains functions useful through out the code generator.
   5 --
   6
   7 module LlvmCodeGen.Base (
   8
   9         LlvmCmmTop, LlvmBasicBlock,
  10         LlvmUnresData, LlvmData, UnresLabel, UnresStatic,
  11
  12         LlvmEnv, initLlvmEnv, clearVars, varLookup, varInsert,
  13         funLookup, funInsert,
  14
  15         cmmToLlvmType, widthToLlvmFloat, widthToLlvmInt, llvmFunTy,
  16         llvmFunSig, llvmStdFunAttrs, llvmFunAlign, llvmInfAlign,
  17         llvmPtrBits, mkLlvmFunc, tysToParams,
  18
  19         strCLabel_llvm, genCmmLabelRef, genStringLabelRef
  20
  21     ) where
  22
  23 #include "HsVersions.h"
  24
  25 import Llvm
  26 import LlvmCodeGen.Regs
  27
  28 import CLabel
  29 import CgUtils ( activeStgRegs )
  30 import Constants
  31 import FastString
  32 import OldCmm
  33 import qualified Outputable as Outp
  34 import UniqFM
  35 import Unique
  36
  37 -- ----------------------------------------------------------------------------
  38 -- * Some Data Types
  39 --
  40
  41 type LlvmCmmTop = GenCmmTop LlvmData [CmmStatic] (ListGraph LlvmStatement)
  42 type LlvmBasicBlock = GenBasicBlock LlvmStatement
  43
  44 -- | Unresolved code.
  45 -- Of the form: (data label, data type, unresolved data)
  46 type LlvmUnresData = (CLabel, Section, LlvmType, [UnresStatic])
  47
  48 -- | Top level LLVM Data (globals and type aliases)
  49 type LlvmData = ([LMGlobal], [LlvmType])
  50
  51 -- | An unresolved Label.
  52 --
  53 -- Labels are unresolved when we haven't yet determined if they are defined in
  54 -- the module we are currently compiling, or an external one.
  55 type UnresLabel  = CmmLit
  56 type UnresStatic = Either UnresLabel LlvmStatic
  57
  58 -- ----------------------------------------------------------------------------
  59 -- * Type translations
  60 --
  61
  62 -- | Translate a basic CmmType to an LlvmType.
  63 cmmToLlvmType :: CmmType -> LlvmType
  64 cmmToLlvmType ty | isFloatType ty = widthToLlvmFloat $ typeWidth ty
  65                  | otherwise      = widthToLlvmInt   $ typeWidth ty
  66
  67 -- | Translate a Cmm Float Width to a LlvmType.
  68 widthToLlvmFloat :: Width -> LlvmType
  69 widthToLlvmFloat W32  = LMFloat
  70 widthToLlvmFloat W64  = LMDouble
  71 widthToLlvmFloat W80  = LMFloat80
  72 widthToLlvmFloat W128 = LMFloat128
  73 widthToLlvmFloat w    = panic $ "widthToLlvmFloat: Bad float size: " ++ show w
  74
  75 -- | Translate a Cmm Bit Width to a LlvmType.
  76 widthToLlvmInt :: Width -> LlvmType
  77 widthToLlvmInt w = LMInt $ widthInBits w
  78
  79 -- | GHC Call Convention for LLVM
  80 llvmGhcCC :: LlvmCallConvention
  81 llvmGhcCC = CC_Ncc 10
  82
  83 -- | Llvm Function type for Cmm function
  84 llvmFunTy :: LlvmType
  85 llvmFunTy = LMFunction $ llvmFunSig' (fsLit "a") ExternallyVisible
  86
  87 -- | Llvm Function signature
  88 llvmFunSig :: CLabel -> LlvmLinkageType -> LlvmFunctionDecl
  89 llvmFunSig lbl link = llvmFunSig' (strCLabel_llvm lbl) link
  90
  91 llvmFunSig' :: LMString -> LlvmLinkageType -> LlvmFunctionDecl
  92 llvmFunSig' lbl link
  93   = let toParams x | isPointer x = (x, [NoAlias, NoCapture])
  94                    | otherwise   = (x, [])
  95     in LlvmFunctionDecl lbl link llvmGhcCC LMVoid FixedArgs
  96                         (map (toParams . getVarType) llvmFunArgs) llvmFunAlign
  97
  98 -- | Create a Haskell function in LLVM.
  99 mkLlvmFunc :: CLabel -> LlvmLinkageType -> LMSection -> LlvmBlocks
 100            -> LlvmFunction
 101 mkLlvmFunc lbl link sec blks
 102   = let funDec = llvmFunSig lbl link
 103         funArgs = map (fsLit . getPlainName) llvmFunArgs
 104     in LlvmFunction funDec funArgs llvmStdFunAttrs sec blks
 105
 106 -- | Alignment to use for functions
 107 llvmFunAlign :: LMAlign
 108 llvmFunAlign = Just wORD_SIZE
 109
 110 -- | Alignment to use for into tables
 111 llvmInfAlign :: LMAlign
 112 llvmInfAlign = Just wORD_SIZE
 113
 114 -- | A Function's arguments
 115 llvmFunArgs :: [LlvmVar]
 116 llvmFunArgs = map lmGlobalRegArg activeStgRegs
 117
 118 -- | Llvm standard fun attributes
 119 llvmStdFunAttrs :: [LlvmFuncAttr]
 120 llvmStdFunAttrs = [NoUnwind]
 121
 122 -- | Convert a list of types to a list of function parameters
 123 -- (each with no parameter attributes)
 124 tysToParams :: [LlvmType] -> [LlvmParameter]
 125 tysToParams = map (\ty -> (ty, []))
 126
 127 -- | Pointer width
 128 llvmPtrBits :: Int
 129 llvmPtrBits = widthInBits $ typeWidth gcWord
 130
 131
 132 -- ----------------------------------------------------------------------------
 133 -- * Environment Handling
 134 --
 135
 136 type LlvmEnvMap = UniqFM LlvmType
 137 -- two maps, one for functions and one for local vars.
 138 type LlvmEnv = (LlvmEnvMap, LlvmEnvMap)
 139
 140 -- | Get initial Llvm environment.
 141 initLlvmEnv :: LlvmEnv
 142 initLlvmEnv = (emptyUFM, emptyUFM)
 143
 144 -- | Clear variables from the environment.
 145 clearVars :: LlvmEnv -> LlvmEnv
 146 clearVars (e1, _) = (e1, emptyUFM)
 147
 148 -- | Insert functions into the environment.
 149 varInsert, funInsert :: Uniquable key => key -> LlvmType -> LlvmEnv -> LlvmEnv
 150 varInsert s t (e1, e2) = (e1, addToUFM e2 s t)
 151 funInsert s t (e1, e2) = (addToUFM e1 s t, e2)
 152
 153 -- | Lookup functions in the environment.
 154 varLookup, funLookup :: Uniquable key => key -> LlvmEnv -> Maybe LlvmType
 155 varLookup s (_, e2) = lookupUFM e2 s
 156 funLookup s (e1, _) = lookupUFM e1 s
 157
 158
 159 -- ----------------------------------------------------------------------------
 160 -- * Label handling
 161 --
 162
 163 -- | Pretty print a 'CLabel'.
 164 strCLabel_llvm :: CLabel -> LMString
 165 strCLabel_llvm l = (fsLit . show . llvmSDoc . pprCLabel) l
 166
 167 -- | Create an external definition for a 'CLabel' defined in another module.
 168 genCmmLabelRef :: CLabel -> LMGlobal
 169 genCmmLabelRef = genStringLabelRef . strCLabel_llvm
 170
 171 -- | As above ('genCmmLabelRef') but taking a 'LMString', not 'CLabel'.
 172 genStringLabelRef :: LMString -> LMGlobal
 173 genStringLabelRef cl
 174   = let ty = LMPointer $ LMArray 0 llvmWord
 175     in (LMGlobalVar cl ty External Nothing Nothing False, Nothing)
 176
 177
 178 -- ----------------------------------------------------------------------------
 179 -- * Misc
 180 --
 181
 182 -- | Error function
 183 panic :: String -> a
 184 panic s = Outp.panic $ "LlvmCodeGen.Base." ++ s
 185