[commit: ghc] wip/simd: Fixup stack spills when generating AVX instructions. (3d40db7)

[git at git.haskell.org]

Repository : ssh://git@git.haskell.org/ghc

On branch  : wip/simd
Link       : http://ghc.haskell.org/trac/ghc/changeset/3d40db7d2b8eb4285a035c20582c8aaf173adce8/ghc

>---------------------------------------------------------------

commit 3d40db7d2b8eb4285a035c20582c8aaf173adce8
Author: Geoffrey Mainland <gmainlan at microsoft.com>
Date:   Sat Nov 26 12:45:23 2011 +0000

    Fixup stack spills when generating AVX instructions.
    
    LLVM uses aligned AVX moves to spill values onto the stack, which requires
    32-bye aligned stacks. Since the stack in only 16-byte aligned, LLVM inserts
    extra instructions that munge the stack pointer. This is very very bad for the
    GHC calling convention, so we tell LLVM to assume the stack is 32-byte
    aligned. This patch rewrites the spill instructions that LLVM generates so they
    do not require an aligned stack.


>---------------------------------------------------------------

3d40db7d2b8eb4285a035c20582c8aaf173adce8
 compiler/llvmGen/LlvmMangler.hs |   39 ++++++++++++++++++++++++++++++++++++++-
 1 file changed, 38 insertions(+), 1 deletion(-)

diff --git a/compiler/llvmGen/LlvmMangler.hs b/compiler/llvmGen/LlvmMangler.hs
index 83a2be7..5f74dc4 100644
--- a/compiler/llvmGen/LlvmMangler.hs
+++ b/compiler/llvmGen/LlvmMangler.hs
@@ -20,6 +20,10 @@ import System.IO
 import Data.List ( sortBy )
 import Data.Function ( on )
 
+#if x86_64_TARGET_ARCH
+#define REWRITE_AVX
+#endif
+
 -- Magic Strings
 secStmt, infoSec, newLine, textStmt, dataStmt, syntaxUnified :: B.ByteString
 secStmt       = B.pack "\t.section\t"
@@ -47,7 +51,7 @@ llvmFixupAsm dflags f1 f2 = {-# SCC "llvm_mangler" #-} do
     w <- openBinaryFile f2 WriteMode
     ss <- readSections r w
     hClose r
-    let fixed = fixTables ss
+    let fixed = (map rewriteAVX . fixTables) ss
     mapM_ (writeSection w) fixed
     hClose w
     return ()
@@ -90,6 +94,39 @@ writeSection w (hdr, cts) = do
     B.hPutStrLn w hdr
   B.hPutStrLn w cts
 
+#if REWRITE_AVX
+rewriteAVX :: Section -> Section
+rewriteAVX = rewriteVmovaps . rewriteVmovdqa
+
+rewriteVmovdqa :: Section -> Section
+rewriteVmovdqa = rewriteInstructions vmovdqa vmovdqu
+  where
+    vmovdqa, vmovdqu :: B.ByteString
+    vmovdqa = B.pack "vmovdqa"
+    vmovdqu = B.pack "vmovdqu"
+
+rewriteVmovap :: Section -> Section
+rewriteVmovap = rewriteInstructions vmovap vmovup
+  where
+    vmovap, vmovup :: B.ByteString
+    vmovap = B.pack "vmovap"
+    vmovup = B.pack "vmovup"
+
+rewriteInstructions :: B.ByteString -> B.ByteString -> Section -> Section
+rewriteInstructions matchBS replaceBS (hdr, cts) =
+    (hdr, loop cts)
+  where
+    loop :: B.ByteString -> B.ByteString
+    loop cts =
+        case B.breakSubstring cts matchBS of
+          (hd,tl) | B.null tl -> hd
+                  | otherwise -> hd `B.append` replaceBS `B.append`
+                                 loop (B.drop (B.length matchBS) tl)
+#else /* !REWRITE_AVX */
+rewriteAVX :: Section -> Section
+rewriteAVX = id
+#endif /* !REWRITE_SSE */
+
 -- | Reorder and convert sections so info tables end up next to the
 -- code. Also does stack fixups.
 fixTables :: [Section] -> [Section]