[Git][ghc/ghc][ghc-8.8] Stack: fix name mangling.

[Ben Gamari]

Ben Gamari pushed to branch ghc-8.8 at Glasgow Haskell Compiler / GHC


Commits:
3306cd5c by Tamar Christina at 2020-04-22T12:32:54-04:00
Stack: fix name mangling.

(cherry picked from commit fb031b9b046e48ffe0d2864ec76bee3bc8ff5625)

- - - - -


4 changed files:

- compiler/nativeGen/X86/Instr.hs
- + testsuite/tests/profiling/should_compile/T16166/Main.hs
- + testsuite/tests/profiling/should_compile/T16166/NetworkRequestHeader.hs
- + testsuite/tests/profiling/should_compile/T16166/all.T


Changes:

=====================================
compiler/nativeGen/X86/Instr.hs
=====================================
@@ -942,7 +942,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 ->


=====================================
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 []
+


=====================================
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
+


=====================================
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'])



View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/3306cd5c16f71684bd49c338d5a2b1981197ffc3

-- 
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/3306cd5c16f71684bd49c338d5a2b1981197ffc3
You're receiving this email because of your account on gitlab.haskell.org.


-------------- next part --------------
An HTML attachment was scrubbed...
URL: <http://mail.haskell.org/pipermail/ghc-commits/attachments/20200422/82fb29ea/attachment-0001.html>