LLVM: Add in new LLVM mangler for implementing TNTC on OSX

[ghc-hetmet.git] / compiler / llvmGen / LlvmCodeGen / Ppr.hs

diff --git a/compiler/llvmGen/LlvmCodeGen/Ppr.hs b/compiler/llvmGen/LlvmCodeGen/Ppr.hs
index b31e6ff..daadc55 100644 (file)
--- a/compiler/llvmGen/LlvmCodeGen/Ppr.hs
+++ b/compiler/llvmGen/LlvmCodeGen/Ppr.hs
@@ -16,9 +16,9 @@ import CLabel
 import Cmm
 
 import FastString
+import qualified Outputable
 import Pretty
 import Unique
-import Util
 
 -- ----------------------------------------------------------------------------
 -- * Top level
@@ -30,7 +30,7 @@ moduleLayout =
 #if i386_TARGET_ARCH
 
 #if darwin_TARGET_OS
-    text "target datalayout = \"e-p:32:32:32-i1:8:8-i8:8:8-i16:16:16-i32:32:32-i64:32:64-f32:32:32-f64:32:64-v64:64:64-v128:128:128-a0:0:64-f80:128:128\""
+    text "target datalayout = \"e-p:32:32:32-i1:8:8-i8:8:8-i16:16:16-i32:32:32-i64:32:64-f32:32:32-f64:32:64-v64:64:64-v128:128:128-a0:0:64-f80:128:128-n8:16:32\""
     $+$ text "target triple = \"i386-apple-darwin9.8\""
 #elif mingw32_TARGET_OS
     text "target datalayout = \"e-p:32:32:32-i1:8:8-i8:8:8-i16:16:16-i32:32:32-i64:64:64-f32:32:32-f64:64:64-f80:128:128-v64:64:64-v128:128:128-a0:0:64-f80:32:32-n8:16:32\""
@@ -40,19 +40,21 @@ moduleLayout =
     $+$ text "target triple = \"i386-pc-linux-gnu\""
 #endif
 
-#else
+#elif x86_64_TARGET_ARCH
 
-#ifdef x86_64_TARGET_ARCH
-    text "target datalayout = \"e-p:64:64:64-i1:8:8-i8:8:8-i16:16:16-i32:32:32-i64:64:64-f32:32:32-f64:64:64-v64:64:64-v128:128:128-a0:0:64-s0:64:64-f80:128:128\""
+#if darwin_TARGET_OS
+    text "target datalayout = \"e-p:64:64:64-i1:8:8-i8:8:8-i16:16:16-i32:32:32-i64:64:64-f32:32:32-f64:64:64-v64:64:64-v128:128:128-a0:0:64-s0:64:64-f80:128:128-n8:16:32:64\""
+    $+$ text "target triple = \"x86_64-apple-darwin10.0.0\""
+#else /* Linux */
+    text "target datalayout = \"e-p:64:64:64-i1:8:8-i8:8:8-i16:16:16-i32:32:32-i64:64:64-f32:32:32-f64:64:64-v64:64:64-v128:128:128-a0:0:64-s0:64:64-f80:128:128-n8:16:32:64\""
     $+$ text "target triple = \"x86_64-linux-gnu\""
+#endif
 
-#else /* Not i386 */
+#else /* Not x86 */
     -- FIX: Other targets
     empty
 #endif
 
-#endif
-
 
 -- | Header code for LLVM modules
 pprLlvmHeader :: Doc
@@ -65,7 +67,11 @@ pprLlvmData (globals, types) =
     let tryConst (v, Just s )   = ppLlvmGlobal (v, Just s)
         tryConst g@(_, Nothing) = ppLlvmGlobal g
 
-        types'   = ppLlvmTypes types
+        ppLlvmTys (LMAlias    a) = ppLlvmAlias a
+        ppLlvmTys (LMFunction f) = ppLlvmFunctionDecl f
+        ppLlvmTys _other         = empty
+
+        types'   = vcat $ map ppLlvmTys types
         globals' = vcat $ map tryConst globals
     in types' $+$ globals'
 
@@ -78,7 +84,7 @@ pprLlvmCmmTop _ _ (CmmData _ lmdata)
 pprLlvmCmmTop env count (CmmProc info lbl _ (ListGraph blks))
   = let static = CmmDataLabel lbl : info
         (idoc, ivar) = if not (null info)
-                          then pprCmmStatic env count static
+                          then pprInfoTable env count lbl static
                           else (empty, [])
     in (idoc $+$ (
         let sec = mkLayoutSection (count + 1)
@@ -88,28 +94,32 @@ pprLlvmCmmTop env count (CmmProc info lbl _ (ListGraph blks))
             link = if externallyVisibleCLabel lbl'
                       then ExternallyVisible
                       else Internal
-            funDec = llvmFunSig lbl' link
             lmblocks = map (\(BasicBlock id stmts) ->
                                 LlvmBlock (getUnique id) stmts) blks
-            fun = LlvmFunction funDec [NoUnwind] sec' lmblocks
+            fun = mkLlvmFunc lbl' link  sec' lmblocks
         in ppLlvmFunction fun
     ), ivar)
 
 
 -- | Pretty print CmmStatic
-pprCmmStatic :: LlvmEnv -> Int -> [CmmStatic] -> (Doc, [LlvmVar])
-pprCmmStatic env count stat
+pprInfoTable :: LlvmEnv -> Int -> CLabel -> [CmmStatic] -> (Doc, [LlvmVar])
+pprInfoTable env count lbl stat
   = let unres = genLlvmData (Text, stat)
         (_, (ldata, ltypes)) = resolveLlvmData env unres
 
-        setSection (gv@(LMGlobalVar s ty l _ _ c), d)
-            = let v = if l == Internal then [gv] else []
-                  sec = mkLayoutSection count
-              in ((LMGlobalVar s ty l sec llvmInfAlign c, d), v)
+        setSection ((LMGlobalVar _ ty l _ _ c), d)
+            = let sec = mkLayoutSection count
+                  ilabel = strCLabel_llvm (entryLblToInfoLbl lbl)
+                              `appendFS` (fsLit "_itable")
+                  gv = LMGlobalVar ilabel ty l sec llvmInfAlign c
+                  v = if l == Internal then [gv] else []
+              in ((gv, d), v)
         setSection v = (v,[])
 
-        (ldata', llvmUsed) = mapAndUnzip setSection ldata
-    in (pprLlvmData (ldata', ltypes), concat llvmUsed)
+        (ldata', llvmUsed) = setSection (last ldata)
+    in if length ldata /= 1
+          then Outputable.panic "LlvmCodeGen.Ppr: invalid info table!"
+          else (pprLlvmData ([ldata'], ltypes), llvmUsed)
 
 
 -- | Create an appropriate section declaration for subsection <n> of text
@@ -119,5 +129,12 @@ pprCmmStatic env count stat
 -- so we are hoping it does.
 mkLayoutSection :: Int -> LMSection
 mkLayoutSection n
-  = Just (fsLit $ ".text;.text " ++ show n ++ " #")
+#if darwin_TARGET_OS
+  -- On OSX we can't use the GNU Assembler, we must use the OSX assembler, which
+  -- doesn't support subsections. So we post process the assembly code, this
+  -- section specifier will be replaced with '.text' by the mangler.
+  = Just (fsLit $ "__STRIP,__me" ++ show n)
+#else
+  = Just (fsLit $ ".text # .text " ++ show n ++ " #")
+#endif