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 CgUtils ( activeStgRegs )
  29 import CLabel
  30 import Cmm
  31
  32 import FastString
  33 import qualified Outputable as Outp
  34 import Unique
  35 import UniqFM
  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, unresovled 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 = LlvmFunctionDecl lbl link llvmGhcCC LMVoid FixedArgs
  93                         (tysToParams $ map getVarType llvmFunArgs) llvmFunAlign
  94
  95 -- | Create a Haskell function in LLVM.
  96 mkLlvmFunc :: CLabel -> LlvmLinkageType -> LMSection -> LlvmBlocks -> LlvmFunction
  97 mkLlvmFunc lbl link sec blks
  98   = let funDec = llvmFunSig lbl link
  99         funArgs = map (fsLit . getPlainName) llvmFunArgs
 100     in LlvmFunction funDec funArgs llvmStdFunAttrs sec blks
 101
 102 -- | Alignment to use for functions
 103 llvmFunAlign :: LMAlign
 104 llvmFunAlign = Just 4
 105
 106 -- | Alignment to use for into tables
 107 llvmInfAlign :: LMAlign
 108 llvmInfAlign = Just 4
 109
 110 -- | A Function's arguments
 111 llvmFunArgs :: [LlvmVar]
 112 llvmFunArgs = map lmGlobalRegArg activeStgRegs
 113
 114 -- | Llvm standard fun attributes
 115 llvmStdFunAttrs :: [LlvmFuncAttr]
 116 llvmStdFunAttrs = [NoUnwind]
 117
 118 -- | Convert a list of types to a list of function parameters
 119 -- (each with no parameter attributes)
 120 tysToParams :: [LlvmType] -> [LlvmParameter]
 121 tysToParams = map (\ty -> (ty, []))
 122
 123 -- | Pointer width
 124 llvmPtrBits :: Int
 125 llvmPtrBits = widthInBits $ typeWidth gcWord
 126
 127
 128 -- ----------------------------------------------------------------------------
 129 -- * Environment Handling
 130 --
 131
 132 type LlvmEnvMap = UniqFM LlvmType
 133 -- two maps, one for functions and one for local vars.
 134 type LlvmEnv = (LlvmEnvMap, LlvmEnvMap)
 135
 136 -- | Get initial Llvm environment.
 137 initLlvmEnv :: LlvmEnv
 138 initLlvmEnv = (emptyUFM, emptyUFM)
 139
 140 -- | Clear variables from the environment.
 141 clearVars :: LlvmEnv -> LlvmEnv
 142 clearVars (e1, _) = (e1, emptyUFM)
 143
 144 -- | Insert functions into the environment.
 145 varInsert, funInsert :: Uniquable key => key -> LlvmType -> LlvmEnv -> LlvmEnv
 146 varInsert s t (e1, e2) = (e1, addToUFM e2 s t)
 147 funInsert s t (e1, e2) = (addToUFM e1 s t, e2)
 148
 149 -- | Lookup functions in the environment.
 150 varLookup, funLookup :: Uniquable key => key -> LlvmEnv -> Maybe LlvmType
 151 varLookup s (_, e2) = lookupUFM e2 s
 152 funLookup s (e1, _) = lookupUFM e1 s
 153
 154
 155 -- ----------------------------------------------------------------------------
 156 -- * Label handling
 157 --
 158
 159 -- | Pretty print a 'CLabel'.
 160 strCLabel_llvm :: CLabel -> LMString
 161 strCLabel_llvm l = (fsLit . show . llvmSDoc . pprCLabel) l
 162
 163 -- | Create an external definition for a 'CLabel' defined in another module.
 164 genCmmLabelRef :: CLabel -> LMGlobal
 165 genCmmLabelRef = genStringLabelRef . strCLabel_llvm
 166
 167 -- | As above ('genCmmLabelRef') but taking a 'LMString', not 'CLabel'.
 168 genStringLabelRef :: LMString -> LMGlobal
 169 genStringLabelRef cl
 170   = let ty = LMPointer $ LMArray 0 llvmWord
 171     in (LMGlobalVar cl ty External Nothing Nothing False, Nothing)
 172
 173
 174 -- ----------------------------------------------------------------------------
 175 -- * Misc
 176 --
 177
 178 -- | Error function
 179 panic :: String -> a
 180 panic s = Outp.panic $ "LlvmCodeGen.Base." ++ s
 181