[commit: ghc] : Stack: fix name mangling. (0f253b8)

[git at git.haskell.org]

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

On branch  : 
Link       : http://ghc.haskell.org/trac/ghc/changeset/0f253b890ca3aff79622cad6433a623795cd8ff7/ghc

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

commit 0f253b890ca3aff79622cad6433a623795cd8ff7
Author: Tamar Christina <tamar at zhox.com>
Date:   Sun Jan 27 15:54:36 2019 +0000

    Stack: fix name mangling.
    
    (cherry picked from commit fb031b9b046e48ffe0d2864ec76bee3bc8ff5625)


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

0f253b890ca3aff79622cad6433a623795cd8ff7
 compiler/nativeGen/X86/Instr.hs                    |  2 +-
 .../tests/profiling/should_compile/T16166/Main.hs  | 11 ++++
 .../should_compile/T16166/NetworkRequestHeader.hs  | 76 ++++++++++++++++++++++
 .../tests/profiling/should_compile/T16166/all.T    |  7 ++
 4 files changed, 95 insertions(+), 1 deletion(-)

diff --git a/compiler/nativeGen/X86/Instr.hs b/compiler/nativeGen/X86/Instr.hs
index c7000c9..1a612b8 100644
--- a/compiler/nativeGen/X86/Instr.hs
+++ b/compiler/nativeGen/X86/Instr.hs
@@ -934,7 +934,7 @@ x86_mkStackAllocInstr platform amount
                            ]
             ArchX86_64 | needs_probe_call platform amount ->
                            [ MOV II64 (OpImm (ImmInt amount)) (OpReg rax)
-                           , CALL (Left $ strImmLit "__chkstk_ms") [rax]
+                           , CALL (Left $ strImmLit "___chkstk_ms") [rax]
                            , SUB II64 (OpReg rax) (OpReg rsp)
                            ]
                        | otherwise ->
diff --git a/testsuite/tests/profiling/should_compile/T16166/Main.hs b/testsuite/tests/profiling/should_compile/T16166/Main.hs
new file mode 100644
index 0000000..09dbb87
--- /dev/null
+++ b/testsuite/tests/profiling/should_compile/T16166/Main.hs
@@ -0,0 +1,11 @@
+{-# LANGUAGE BangPatterns #-}
+-- Main.hs
+module Main (main) where
+
+import NetworkRequestHeader
+
+import Control.Monad
+
+main :: IO ()
+main = void $ parseHeaderLines []
+
diff --git a/testsuite/tests/profiling/should_compile/T16166/NetworkRequestHeader.hs b/testsuite/tests/profiling/should_compile/T16166/NetworkRequestHeader.hs
new file mode 100644
index 0000000..48a6288
--- /dev/null
+++ b/testsuite/tests/profiling/should_compile/T16166/NetworkRequestHeader.hs
@@ -0,0 +1,76 @@
+{-# LANGUAGE BangPatterns #-}
+-- NetworkRequestHeader.hs
+module NetworkRequestHeader (parseHeaderLines, parseRequestLine) where
+
+import Control.Exception
+import Control.Monad
+import Data.ByteString.Internal (ByteString(..), memchr)
+import Data.Word
+import Foreign.ForeignPtr (withForeignPtr)
+import Foreign.Ptr (Ptr, plusPtr, minusPtr, nullPtr)
+import Foreign.Storable (peek)
+
+-- | Error types for bad 'Request'.
+data InvalidRequest = NonHttp
+
+instance Show InvalidRequest where show _ = ""
+instance Exception InvalidRequest
+
+parseHeaderLines :: [ByteString]
+                 -> IO (ByteString
+                       ,ByteString  --  Path
+                       ,ByteString  --  Path, parsed
+                       )
+parseHeaderLines [] = throwIO $ NonHttp
+parseHeaderLines (firstLine:_) = do
+    (method, path') <- parseRequestLine firstLine
+    let path = path'
+    return (method, path', path)
+
+parseRequestLine :: ByteString
+                 -> IO (ByteString
+                       ,ByteString)
+parseRequestLine (PS fptr off len) = withForeignPtr fptr $ \ptr -> do
+    when (len < 14) $ throwIO NonHttp
+    let methodptr = ptr `plusPtr` off
+        limptr = methodptr `plusPtr` len
+        lim0 = fromIntegral len
+
+    pathptr0 <- memchr methodptr 32 lim0 -- ' '
+    when (pathptr0 == nullPtr || (limptr `minusPtr` pathptr0) < 11) $
+        throwIO NonHttp
+    let pathptr = pathptr0 `plusPtr` 1
+        lim1 = fromIntegral (limptr `minusPtr` pathptr0)
+
+    httpptr0 <- memchr pathptr 32 lim1 -- ' '
+    when (httpptr0 == nullPtr || (limptr `minusPtr` httpptr0) < 9) $
+        throwIO NonHttp
+    let httpptr = httpptr0 `plusPtr` 1
+        lim2 = fromIntegral (httpptr0 `minusPtr` pathptr)
+
+    checkHTTP httpptr
+    queryptr <- memchr pathptr 63 lim2 -- '?'
+
+    let !method = bs ptr methodptr pathptr0
+        !path
+          | queryptr == nullPtr = bs ptr pathptr httpptr0
+          | otherwise           = bs ptr pathptr queryptr
+
+    return (method,path)
+  where
+    check :: Ptr Word8 -> Int -> Word8 -> IO ()
+    check p n w = do
+        w0 <- peek $ p `plusPtr` n
+        when (w0 /= w) $ throwIO NonHttp
+    checkHTTP httpptr = do
+        check httpptr 0 72 -- 'H'
+        check httpptr 1 84 -- 'T'
+        check httpptr 2 84 -- 'T'
+        check httpptr 3 80 -- 'P'
+        check httpptr 4 47 -- '/'
+        check httpptr 6 46 -- '.'
+    bs ptr p0 p1 = PS fptr o l
+      where
+        o = p0 `minusPtr` ptr
+        l = p1 `minusPtr` p0
+
diff --git a/testsuite/tests/profiling/should_compile/T16166/all.T b/testsuite/tests/profiling/should_compile/T16166/all.T
new file mode 100644
index 0000000..31f129b
--- /dev/null
+++ b/testsuite/tests/profiling/should_compile/T16166/all.T
@@ -0,0 +1,7 @@
+# We need the register allocator to use more than a page worth of stack space
+# when spilling in a single function, easiest way to do that is
+# using a profiling build
+test('T16166', [only_ways(['normal']), req_profiling,
+                extra_files(['Main.hs', 'NetworkRequestHeader.hs'])],
+     multimod_compile,
+     ['Main NetworkRequestHeader', '-O -prof -fprof-auto -v0'])