--- /dev/null
+-- ----------------------------------------------------------------------------
+-- | 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
+
projects / ghc-hetmet.git / blobdiff