Add new LLVM code generator to GHC. (Version 2)

This was done as part of an honours thesis at UNSW, the paper describing the
work and results can be found at:

http://www.cse.unsw.edu.au/~pls/thesis/davidt-thesis.pdf

A Homepage for the backend can be found at:

http://hackage.haskell.org/trac/ghc/wiki/Commentary/Compiler/Backends/LLVM

Quick summary of performance is that for the 'nofib' benchmark suite, runtimes
are within 5% slower than the NCG and generally better than the C code
generator.  For some code though, such as the DPH projects benchmark, the LLVM
code generator outperforms the NCG and C code generator by about a 25%
reduction in run times.

1 files changed, 190 insertions, 0 deletions

diff --git a/compiler/llvmGen/LlvmCodeGen/Data.hs b/compiler/llvmGen/LlvmCodeGen/Data.hs
new file mode 100644
index 0000000000..a5b82aadf2
--- /dev/null
+++ b/compiler/llvmGen/LlvmCodeGen/Data.hs
@@ -0,0 +1,190 @@
+-- ----------------------------------------------------------------------------
+-- | Handle conversion of CmmData to LLVM code.
+--
+
+module LlvmCodeGen.Data (
+        genLlvmData, resolveLlvmDatas, resolveLlvmData
+    ) where
+
+#include "HsVersions.h"
+
+import Llvm
+import LlvmCodeGen.Base
+
+import BlockId
+import CLabel
+import Cmm
+
+import DynFlags
+import FastString
+import qualified Outputable
+
+import Data.Maybe
+
+
+-- ----------------------------------------------------------------------------
+-- * Constants
+--
+
+-- | The string appended to a variable name to create its structure type alias
+structStr :: LMString
+structStr = fsLit "_struct"
+
+-- ----------------------------------------------------------------------------
+-- * Top level
+--
+
+-- | Pass a CmmStatic section to an equivalent Llvm code. Can't
+-- complete this completely though as we need to pass all CmmStatic
+-- sections before all references can be resolved. This last step is
+-- done by 'resolveLlvmData'.
+genLlvmData :: DynFlags -> (Section, [CmmStatic]) -> LlvmUnresData
+genLlvmData _ ( _ , (CmmDataLabel lbl):xs) =
+    let static  = map genData xs
+        label   = strCLabel_llvm lbl
+
+        types   = map getStatTypes static
+        getStatTypes (Left  x) = cmmToLlvmType $ cmmLitType x
+        getStatTypes (Right x) = getStatType x
+
+        strucTy = LMStruct types
+        alias   = LMAlias (label `appendFS` structStr) strucTy
+    in (lbl, alias, static)
+
+genLlvmData _ _ = panic "genLlvmData: CmmData section doesn't start with label!"
+
+resolveLlvmDatas :: DynFlags -> LlvmEnv -> [LlvmUnresData] -> [LlvmData]
+                 -> (LlvmEnv, [LlvmData])
+resolveLlvmDatas _ env [] ldata
+  = (env, ldata)
+
+resolveLlvmDatas dflags env (udata : rest) ldata
+  = let (env', ndata) = resolveLlvmData dflags env udata
+    in resolveLlvmDatas dflags env' rest (ldata ++ [ndata])
+
+-- | Fix up CLabel references now that we should have passed all CmmData.
+resolveLlvmData :: DynFlags -> LlvmEnv -> LlvmUnresData -> (LlvmEnv, LlvmData)
+resolveLlvmData _ env (lbl, alias, unres) =
+    let (env', static, refs) = resDatas env unres ([], [])
+        refs'          = catMaybes refs
+        struct         = Just $ LMStaticStruc static alias
+        label          = strCLabel_llvm lbl
+        link           = if (externallyVisibleCLabel lbl)
+                            then ExternallyVisible else Internal
+        glob           = LMGlobalVar label alias link
+    in (env', (refs' ++ [(glob, struct)], [alias]))
+
+
+-- ----------------------------------------------------------------------------
+-- ** Resolve Data/CLabel references
+--
+
+-- | Resolve data list
+resDatas :: LlvmEnv -> [UnresStatic] -> ([LlvmStatic], [Maybe LMGlobal])
+         -> (LlvmEnv, [LlvmStatic], [Maybe LMGlobal])
+
+resDatas env [] (stat, glob)
+  = (env, stat, glob)
+
+resDatas env (cmm : rest) (stats, globs)
+  = let (env', nstat, nglob) = resData env cmm
+    in resDatas env' rest (stats ++ [nstat], globs ++ nglob)
+
+-- | Resolve an individual static label if it needs to be.
+--
+-- We check the 'LlvmEnv' to see if the reference has been defined in this
+-- module. If it has we can retrieve its type and make a pointer, otherwise
+-- we introduce a generic external defenition for the referenced label and
+-- then make a pointer.
+resData :: LlvmEnv -> UnresStatic -> (LlvmEnv, LlvmStatic, [Maybe LMGlobal])
+
+resData env (Right stat) = (env, stat, [Nothing])
+
+resData env (Left cmm@(CmmLabel l)) =
+    let label = strCLabel_llvm l
+        ty = funLookup label env
+        lmty = cmmToLlvmType $ cmmLitType cmm
+    in case ty of
+            -- Make generic external label defenition and then pointer to it
+            Nothing ->
+                let glob@(var, _) = genStringLabelRef label
+                    env' =  funInsert label (pLower $ getVarType var) env
+                    ptr  = LMStaticPointer var
+                in  (env', LMPtoI ptr lmty, [Just glob])
+            -- Referenced data exists in this module, retrieve type and make
+            -- pointer to it.
+            Just ty' ->
+                let var = LMGlobalVar label (LMPointer ty') ExternallyVisible
+                    ptr  = LMStaticPointer var
+                in (env, LMPtoI ptr lmty, [Nothing])
+
+resData env (Left (CmmLabelOff label off)) =
+    let (env', var, glob) = resData env (Left (CmmLabel label))
+        offset = LMStaticLit $ LMIntLit (toInteger off) llvmWord
+    in (env', LMAdd var offset, glob)
+
+resData env (Left (CmmLabelDiffOff l1 l2 off)) =
+    let (env1, var1, glob1) = resData env (Left (CmmLabel l1))
+        (env2, var2, glob2) = resData env1 (Left (CmmLabel l2))
+        var = LMSub var1 var2
+        offset = LMStaticLit $ LMIntLit (toInteger off) llvmWord
+    in (env2, LMAdd var offset, glob1 ++ glob2)
+
+resData _ _ = panic "resData: Non CLabel expr as left type!"
+
+-- ----------------------------------------------------------------------------
+-- * Generate static data
+--
+
+-- | Handle static data
+-- Don't handle 'CmmAlign' or a 'CmmDataLabel'.
+genData :: CmmStatic -> UnresStatic
+
+genData (CmmString str) =
+    let v  = map (\x -> LMStaticLit $ LMIntLit (fromIntegral x) i8) str
+        ve = v ++ [LMStaticLit $ LMIntLit 0 i8]
+    in Right $ LMStaticArray ve (LMArray (length ve) i8)
+
+genData (CmmUninitialised bytes)
+    = Right $ LMUninitType (LMArray bytes i8)
+
+genData (CmmStaticLit lit)
+    = genStaticLit lit
+
+genData (CmmAlign _)
+    = panic "genData: Can't handle CmmAlign!"
+
+genData (CmmDataLabel _)
+    = panic "genData: Can't handle data labels not at top of data!"
+
+
+-- | Generate Llvm code for a static literal.
+--
+-- Will either generate the code or leave it unresolved if it is a 'CLabel'
+-- which isn't yet known.
+genStaticLit :: CmmLit -> UnresStatic
+genStaticLit (CmmInt i w)
+    = Right $ LMStaticLit (LMIntLit i (LMInt $ widthInBits w))
+
+genStaticLit (CmmFloat r w)
+    = Right $ LMStaticLit (LMFloatLit r (widthToLlvmFloat w))
+
+-- Leave unresolved, will fix later
+genStaticLit c@(CmmLabel        _    ) = Left $ c
+genStaticLit c@(CmmLabelOff     _   _) = Left $ c
+genStaticLit c@(CmmLabelDiffOff _ _ _) = Left $ c
+
+genStaticLit (CmmBlock b) = Left $ CmmLabel $ infoTblLbl b
+
+genStaticLit (CmmHighStackMark)
+    = panic "genStaticLit: CmmHighStackMark unsupported!"
+
+
+-- -----------------------------------------------------------------------------
+-- * Misc
+--
+
+-- | Error Function
+panic :: String -> a
+panic s = Outputable.panic $ "LlvmCodeGen.Data." ++ s
+