X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;ds=sidebyside;f=compiler%2FllvmGen%2FLlvmCodeGen%2FBase.hs;h=221106aec5c9b5a9157ea4dc54656a83560d8670;hb=c5b178be60a5a44abd2f4ddf8c399857678326e2;hp=36ffa18d6335e6a66eae6743706bd8db1fa9272c;hpb=49a8e5c021009430d373d6224b29004c7d18c408;p=ghc-hetmet.git

diff --git a/compiler/llvmGen/LlvmCodeGen/Base.hs b/compiler/llvmGen/LlvmCodeGen/Base.hs
index 36ffa18..221106a 100644
--- a/compiler/llvmGen/LlvmCodeGen/Base.hs
+++ b/compiler/llvmGen/LlvmCodeGen/Base.hs
@@ -9,14 +9,16 @@ module LlvmCodeGen.Base (
         LlvmCmmTop, LlvmBasicBlock,
         LlvmUnresData, LlvmData, UnresLabel, UnresStatic,
 
+        LlvmVersion, defaultLlvmVersion,
+
         LlvmEnv, initLlvmEnv, clearVars, varLookup, varInsert,
-        funLookup, funInsert,
+        funLookup, funInsert, getLlvmVer, setLlvmVer,
 
         cmmToLlvmType, widthToLlvmFloat, widthToLlvmInt, llvmFunTy,
-        llvmFunSig, llvmStdFunAttrs, llvmPtrBits, llvmGhcCC,
+        llvmFunSig, llvmStdFunAttrs, llvmFunAlign, llvmInfAlign,
+        llvmPtrBits, mkLlvmFunc, tysToParams,
 
-        strCLabel_llvm,
-        genCmmLabelRef, genStringLabelRef
+        strCLabel_llvm, genCmmLabelRef, genStringLabelRef
 
     ) where
 
@@ -25,14 +27,14 @@ module LlvmCodeGen.Base (
 import Llvm
 import LlvmCodeGen.Regs
 
-import CgUtils ( activeStgRegs )
 import CLabel
-import Cmm
-
+import CgUtils ( activeStgRegs )
+import Constants
 import FastString
+import OldCmm
 import qualified Outputable as Outp
-import Unique
 import UniqFM
+import Unique
 
 -- ----------------------------------------------------------------------------
 -- * Some Data Types
@@ -42,8 +44,8 @@ type LlvmCmmTop = GenCmmTop LlvmData [CmmStatic] (ListGraph LlvmStatement)
 type LlvmBasicBlock = GenBasicBlock LlvmStatement
 
 -- | Unresolved code.
--- Of the form: (data label, data type, unresovled data)
-type LlvmUnresData = (CLabel, LlvmType, [UnresStatic])
+-- Of the form: (data label, data type, unresolved data)
+type LlvmUnresData = (CLabel, Section, LlvmType, [UnresStatic])
 
 -- | Top level LLVM Data (globals and type aliases)
 type LlvmData = ([LMGlobal], [LlvmType])
@@ -52,7 +54,7 @@ type LlvmData = ([LMGlobal], [LlvmType])
 --
 -- Labels are unresolved when we haven't yet determined if they are defined in
 -- the module we are currently compiling, or an external one.
-type UnresLabel = CmmLit
+type UnresLabel  = CmmLit
 type UnresStatic = Either UnresLabel LlvmStatic
 
 -- ----------------------------------------------------------------------------
@@ -82,17 +84,34 @@ llvmGhcCC = CC_Ncc 10
 
 -- | Llvm Function type for Cmm function
 llvmFunTy :: LlvmType
-llvmFunTy
-  = LMFunction $
-        LlvmFunctionDecl (fsLit "a") ExternallyVisible llvmGhcCC LMVoid FixedArgs
-            (Left $ map getVarType llvmFunArgs)
+llvmFunTy = LMFunction $ llvmFunSig' (fsLit "a") ExternallyVisible
 
 -- | Llvm Function signature
 llvmFunSig :: CLabel -> LlvmLinkageType -> LlvmFunctionDecl
-llvmFunSig lbl link
-  = let n = strCLabel_llvm lbl
-    in LlvmFunctionDecl n link llvmGhcCC LMVoid FixedArgs
-        (Right llvmFunArgs)
+llvmFunSig lbl link = llvmFunSig' (strCLabel_llvm lbl) link
+
+llvmFunSig' :: LMString -> LlvmLinkageType -> LlvmFunctionDecl
+llvmFunSig' lbl link
+  = let toParams x | isPointer x = (x, [NoAlias, NoCapture])
+                   | otherwise   = (x, [])
+    in LlvmFunctionDecl lbl link llvmGhcCC LMVoid FixedArgs
+                        (map (toParams . getVarType) llvmFunArgs) llvmFunAlign
+
+-- | Create a Haskell function in LLVM.
+mkLlvmFunc :: CLabel -> LlvmLinkageType -> LMSection -> LlvmBlocks
+           -> LlvmFunction
+mkLlvmFunc lbl link sec blks
+  = let funDec = llvmFunSig lbl link
+        funArgs = map (fsLit . getPlainName) llvmFunArgs
+    in LlvmFunction funDec funArgs llvmStdFunAttrs sec blks
+
+-- | Alignment to use for functions
+llvmFunAlign :: LMAlign
+llvmFunAlign = Just wORD_SIZE
+
+-- | Alignment to use for into tables
+llvmInfAlign :: LMAlign
+llvmInfAlign = Just wORD_SIZE
 
 -- | A Function's arguments
 llvmFunArgs :: [LlvmVar]
@@ -102,37 +121,59 @@ llvmFunArgs = map lmGlobalRegArg activeStgRegs
 llvmStdFunAttrs :: [LlvmFuncAttr]
 llvmStdFunAttrs = [NoUnwind]
 
+-- | Convert a list of types to a list of function parameters
+-- (each with no parameter attributes)
+tysToParams :: [LlvmType] -> [LlvmParameter]
+tysToParams = map (\ty -> (ty, []))
+
 -- | Pointer width
 llvmPtrBits :: Int
 llvmPtrBits = widthInBits $ typeWidth gcWord
 
+-- ----------------------------------------------------------------------------
+-- * Llvm Version
+--
+
+-- | LLVM Version Number
+type LlvmVersion = Int
+
+-- | The LLVM Version we assume if we don't know
+defaultLlvmVersion :: LlvmVersion
+defaultLlvmVersion = 28
 
 -- ----------------------------------------------------------------------------
 -- * Environment Handling
 --
 
-type LlvmEnvMap = UniqFM LlvmType
 -- two maps, one for functions and one for local vars.
-type LlvmEnv = (LlvmEnvMap, LlvmEnvMap)
+newtype LlvmEnv = LlvmEnv (LlvmEnvMap, LlvmEnvMap, LlvmVersion)
+type LlvmEnvMap = UniqFM LlvmType
 
 -- | Get initial Llvm environment.
 initLlvmEnv :: LlvmEnv
-initLlvmEnv = (emptyUFM, emptyUFM)
+initLlvmEnv = LlvmEnv (emptyUFM, emptyUFM, defaultLlvmVersion)
 
 -- | Clear variables from the environment.
 clearVars :: LlvmEnv -> LlvmEnv
-clearVars (e1, _) = (e1, emptyUFM)
+clearVars (LlvmEnv (e1, _, n)) = LlvmEnv (e1, emptyUFM, n)
 
 -- | Insert functions into the environment.
 varInsert, funInsert :: Uniquable key => key -> LlvmType -> LlvmEnv -> LlvmEnv
-varInsert s t (e1, e2) = (e1, addToUFM e2 s t)
-funInsert s t (e1, e2) = (addToUFM e1 s t, e2)
+varInsert s t (LlvmEnv (e1, e2, n)) = LlvmEnv (e1, addToUFM e2 s t, n)
+funInsert s t (LlvmEnv (e1, e2, n)) = LlvmEnv (addToUFM e1 s t, e2, n)
 
 -- | Lookup functions in the environment.
 varLookup, funLookup :: Uniquable key => key -> LlvmEnv -> Maybe LlvmType
-varLookup s (_, e2) = lookupUFM e2 s
-funLookup s (e1, _) = lookupUFM e1 s
+varLookup s (LlvmEnv (_, e2, _)) = lookupUFM e2 s
+funLookup s (LlvmEnv (e1, _, _)) = lookupUFM e1 s
+
+-- | Get the LLVM version we are generating code for
+getLlvmVer :: LlvmEnv -> LlvmVersion
+getLlvmVer (LlvmEnv (_, _, n)) = n
 
+-- | Set the LLVM version we are generating code for
+setLlvmVer :: LlvmVersion -> LlvmEnv -> LlvmEnv
+setLlvmVer n (LlvmEnv (e1, e2, _)) = LlvmEnv (e1, e2, n)
 
 -- ----------------------------------------------------------------------------
 -- * Label handling
@@ -144,14 +185,13 @@ strCLabel_llvm l = (fsLit . show . llvmSDoc . pprCLabel) l
 
 -- | Create an external definition for a 'CLabel' defined in another module.
 genCmmLabelRef :: CLabel -> LMGlobal
-genCmmLabelRef cl =
-    let mcl = strCLabel_llvm cl
-    in (LMGlobalVar mcl (LMPointer (LMArray 0 llvmWord)) External, Nothing)
+genCmmLabelRef = genStringLabelRef . strCLabel_llvm
 
 -- | As above ('genCmmLabelRef') but taking a 'LMString', not 'CLabel'.
 genStringLabelRef :: LMString -> LMGlobal
-genStringLabelRef cl =
-    (LMGlobalVar cl (LMPointer (LMArray 0 llvmWord)) External, Nothing)
+genStringLabelRef cl
+  = let ty = LMPointer $ LMArray 0 llvmWord
+    in (LMGlobalVar cl ty External Nothing Nothing False, Nothing)
 
 
 -- ----------------------------------------------------------------------------