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