Stack: fix name mangling.

3 files changed, 94 insertions, 0 deletions

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 0000000000..09dbb8763b
--- /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 0000000000..48a6288d14
--- /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 0000000000..31f129bd69
--- /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'])