X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=blobdiff_plain;f=compiler%2FllvmGen%2FLlvmCodeGen%2FBase.hs;h=80d88e6b14a7a2a0b282b27466852f78816b6f13;hp=003c044db880df27b12d3fa241e24ab5f3a2a460;hb=889c084e943779e76d19f2ef5e970ff655f511eb;hpb=24a3fee9f3ff6cef6fe471ab6f0a7ba9ac001faf

diff --git a/compiler/llvmGen/LlvmCodeGen/Base.hs b/compiler/llvmGen/LlvmCodeGen/Base.hs
index 003c044..80d88e6 100644
--- a/compiler/llvmGen/LlvmCodeGen/Base.hs
+++ b/compiler/llvmGen/LlvmCodeGen/Base.hs
@@ -14,7 +14,7 @@ module LlvmCodeGen.Base (
 
         cmmToLlvmType, widthToLlvmFloat, widthToLlvmInt, llvmFunTy,
         llvmFunSig, llvmStdFunAttrs, llvmFunAlign, llvmInfAlign,
-        llvmPtrBits, llvmGhcCC,
+        llvmPtrBits, mkLlvmFunc, tysToParams,
 
         strCLabel_llvm, genCmmLabelRef, genStringLabelRef
 
@@ -25,14 +25,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 +42,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])
@@ -82,25 +82,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) llvmFunAlign
+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) llvmFunAlign
+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 4
+llvmFunAlign = Just wORD_SIZE
 
 -- | Alignment to use for into tables
 llvmInfAlign :: LMAlign
-llvmInfAlign = Just 4
+llvmInfAlign = Just wORD_SIZE
 
 -- | A Function's arguments
 llvmFunArgs :: [LlvmVar]
@@ -110,6 +119,11 @@ 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
@@ -158,7 +172,7 @@ genCmmLabelRef = genStringLabelRef . strCLabel_llvm
 genStringLabelRef :: LMString -> LMGlobal
 genStringLabelRef cl
   = let ty = LMPointer $ LMArray 0 llvmWord
-    in (LMGlobalVar cl ty External Nothing Nothing, Nothing)
+    in (LMGlobalVar cl ty External Nothing Nothing False, Nothing)
 
 
 -- ----------------------------------------------------------------------------