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, llvmPtrBits, llvmGhcCC,
  17
  18         strCLabel_llvm,
  19         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, 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
  86   = LMFunction $
  87         LlvmFunctionDecl (fsLit "a") ExternallyVisible llvmGhcCC LMVoid FixedArgs
  88             (Left $ map getVarType llvmFunArgs)
  89
  90 -- | Llvm Function signature
  91 llvmFunSig :: CLabel -> LlvmLinkageType -> LlvmFunctionDecl
  92 llvmFunSig lbl link
  93   = let n = strCLabel_llvm lbl
  94     in LlvmFunctionDecl n link llvmGhcCC LMVoid FixedArgs
  95         (Right llvmFunArgs)
  96
  97 -- | A Function's arguments
  98 llvmFunArgs :: [LlvmVar]
  99 llvmFunArgs = map lmGlobalRegArg activeStgRegs
 100
 101 -- | Llvm standard fun attributes
 102 llvmStdFunAttrs :: [LlvmFuncAttr]
 103 llvmStdFunAttrs = [NoUnwind]
 104
 105 -- | Pointer width
 106 llvmPtrBits :: Int
 107 llvmPtrBits = widthInBits $ typeWidth gcWord
 108
 109
 110 -- ----------------------------------------------------------------------------
 111 -- * Environment Handling
 112 --
 113
 114 type LlvmEnvMap = UniqFM LlvmType
 115 -- two maps, one for functions and one for local vars.
 116 type LlvmEnv = (LlvmEnvMap, LlvmEnvMap)
 117
 118 -- | Get initial Llvm environment.
 119 initLlvmEnv :: LlvmEnv
 120 initLlvmEnv = (emptyUFM, emptyUFM)
 121
 122 -- | Clear variables from the environment.
 123 clearVars :: LlvmEnv -> LlvmEnv
 124 clearVars (e1, _) = (e1, emptyUFM)
 125
 126 -- | Insert functions into the environment.
 127 varInsert, funInsert :: Uniquable key => key -> LlvmType -> LlvmEnv -> LlvmEnv
 128 varInsert s t (e1, e2) = (e1, addToUFM e2 s t)
 129 funInsert s t (e1, e2) = (addToUFM e1 s t, e2)
 130
 131 -- | Lookup functions in the environment.
 132 varLookup, funLookup :: Uniquable key => key -> LlvmEnv -> Maybe LlvmType
 133 varLookup s (_, e2) = lookupUFM e2 s
 134 funLookup s (e1, _) = lookupUFM e1 s
 135
 136
 137 -- ----------------------------------------------------------------------------
 138 -- * Label handling
 139 --
 140
 141 -- | Pretty print a 'CLabel'.
 142 strCLabel_llvm :: CLabel -> LMString
 143 strCLabel_llvm l = (fsLit . show . llvmSDoc . pprCLabel) l
 144
 145 -- | Create an external definition for a 'CLabel' defined in another module.
 146 genCmmLabelRef :: CLabel -> LMGlobal
 147 genCmmLabelRef cl =
 148     let mcl = strCLabel_llvm cl
 149     in (LMGlobalVar mcl (LMPointer (LMArray 0 llvmWord)) External, Nothing)
 150
 151 -- | As above ('genCmmLabelRef') but taking a 'LMString', not 'CLabel'.
 152 genStringLabelRef :: LMString -> LMGlobal
 153 genStringLabelRef cl =
 154     (LMGlobalVar cl (LMPointer (LMArray 0 llvmWord)) External, Nothing)
 155
 156
 157 -- ----------------------------------------------------------------------------
 158 -- * Misc
 159 --
 160
 161 -- | Error function
 162 panic :: String -> a
 163 panic s = Outp.panic $ "LlvmCodeGen.Base." ++ s
 164