Add tests for trac #5486 and #5681.

3 files changed, 140 insertions, 0 deletions

diff --git a/testsuite/tests/llvm/should_compile/5486.hs b/testsuite/tests/llvm/should_compile/5486.hs
new file mode 100644
index 0000000000..730a7c2854
--- /dev/null
+++ b/testsuite/tests/llvm/should_compile/5486.hs
@@ -0,0 +1,124 @@
+{-# LANGUAGE ForeignFunctionInterface, UnliftedFFITypes, UnboxedTuples,
+             BangPatterns, MagicHash #-}
+
+-- | Test case for Trac #5486
+-- Test case reduced from HsOpenSSL package BN module
+module Bad where
+
+import           Control.Exception hiding (try)
+import           Foreign
+import qualified Data.ByteString as BS
+
+import           Foreign.C.Types
+import           GHC.Base
+import           GHC.Integer.GMP.Internals
+
+newtype BigNum = BigNum (Ptr BIGNUM)
+data BIGNUM
+
+data ByteArray = BA  !ByteArray#
+data MBA       = MBA !(MutableByteArray# RealWorld)
+
+foreign import ccall unsafe "BN_free"
+        _free :: Ptr BIGNUM -> IO ()
+
+foreign import ccall unsafe "BN_bn2mpi"
+        _bn2mpi :: Ptr BIGNUM -> Ptr CChar -> IO CInt
+
+foreign import ccall unsafe "memcpy"
+        _copy_in :: ByteArray# -> Ptr () -> CSize -> IO ()
+
+foreign import ccall unsafe "memcpy"
+        _copy_out :: Ptr () -> ByteArray# -> CSize -> IO ()
+
+unwrapBN :: BigNum -> Ptr BIGNUM
+unwrapBN (BigNum p) = p
+
+wrapBN :: Ptr BIGNUM -> BigNum
+wrapBN = BigNum
+
+bnToInteger :: BigNum -> IO Integer
+bnToInteger bn = do
+  nlimbs <- ((\hsc_ptr -> peekByteOff hsc_ptr 8)) (unwrapBN bn) :: IO CInt
+  case nlimbs of
+    0 -> return 0
+    1 -> do (I# i) <- ((\hsc_ptr -> peekByteOff hsc_ptr 0)) (unwrapBN bn) >>= peek
+            negative <- ((\hsc_ptr -> peekByteOff hsc_ptr 16)) (unwrapBN bn) :: IO CInt
+            if negative == 0
+               then return $ S# i
+               else return $ 0 - (S# i)
+    _ -> do
+      let !(I# nlimbsi) = fromIntegral nlimbs
+          !(I# limbsize) = ((8))
+      (MBA arr) <- newByteArray (nlimbsi *# limbsize)
+      (BA ba) <- freezeByteArray arr
+      limbs <- ((\hsc_ptr -> peekByteOff hsc_ptr 0)) (unwrapBN bn)
+      _ <- _copy_in ba limbs $ fromIntegral $ nlimbs * ((8))
+      negative <- ((\hsc_ptr -> peekByteOff hsc_ptr 16)) (unwrapBN bn) :: IO CInt
+      if negative == 0
+         then return $ J# nlimbsi ba
+         else return $ 0 - (J# nlimbsi ba)
+
+newByteArray :: Int# -> IO MBA
+newByteArray sz = IO $ \s ->
+  case newByteArray# sz s of { (# s', arr #) ->
+  (# s', MBA arr #) }
+
+freezeByteArray :: MutableByteArray# RealWorld -> IO ByteArray
+freezeByteArray arr = IO $ \s ->
+  case unsafeFreezeByteArray# arr s of { (# s', arr' #) ->
+  (# s', BA arr' #) }
+
+integerToBN :: Integer -> IO BigNum
+integerToBN (S# 0#) = do
+  bnptr <- mallocBytes ((24))
+  ((\hsc_ptr -> pokeByteOff hsc_ptr 0)) bnptr nullPtr
+  let one :: CInt
+      one = 1
+      zero :: CInt
+      zero = 0
+  ((\hsc_ptr -> pokeByteOff hsc_ptr 20)) bnptr one
+  ((\hsc_ptr -> pokeByteOff hsc_ptr 8)) bnptr zero
+  ((\hsc_ptr -> pokeByteOff hsc_ptr 12)) bnptr zero
+  ((\hsc_ptr -> pokeByteOff hsc_ptr 16)) bnptr zero
+  return (wrapBN bnptr)
+
+integerToBN (S# v) = do
+  bnptr <- mallocBytes ((24))
+  limbs <- malloc :: IO (Ptr CULong)
+  poke limbs $ fromIntegral $ abs $ I# v
+  ((\hsc_ptr -> pokeByteOff hsc_ptr 0)) bnptr limbs
+  let one :: CInt
+      one = 1
+  ((\hsc_ptr -> pokeByteOff hsc_ptr 20)) bnptr one
+  ((\hsc_ptr -> pokeByteOff hsc_ptr 8)) bnptr one
+  ((\hsc_ptr -> pokeByteOff hsc_ptr 12)) bnptr one
+  ((\hsc_ptr -> pokeByteOff hsc_ptr 16)) bnptr (if (I# v) < 0 then one else 0)
+  return (wrapBN bnptr)
+
+integerToBN v@(J# nlimbs_ bytearray)
+  | v >= 0 = do
+      let nlimbs = (I# nlimbs_)
+      bnptr <- mallocBytes ((24))
+      limbs <- mallocBytes (((8)) * nlimbs)
+      ((\hsc_ptr -> pokeByteOff hsc_ptr 0)) bnptr limbs
+      ((\hsc_ptr -> pokeByteOff hsc_ptr 20)) bnptr (1 :: CInt)
+      _ <- _copy_out limbs bytearray (fromIntegral $ ((8)) * nlimbs)
+      ((\hsc_ptr -> pokeByteOff hsc_ptr 8)) bnptr ((fromIntegral nlimbs) :: CInt)
+      ((\hsc_ptr -> pokeByteOff hsc_ptr 12)) bnptr ((fromIntegral nlimbs) :: CInt)
+      ((\hsc_ptr -> pokeByteOff hsc_ptr 16)) bnptr (0 :: CInt)
+      return (wrapBN bnptr)
+  | otherwise = do bnptr <- integerToBN (0-v)
+                   ((\hsc_ptr -> pokeByteOff hsc_ptr 16)) (unwrapBN bnptr) (1 :: CInt)
+                   return bnptr
+
+integerToMPI :: Integer -> IO BS.ByteString
+integerToMPI v = bracket (integerToBN v) (_free . unwrapBN) bnToMPI
+
+bnToMPI :: BigNum -> IO BS.ByteString
+bnToMPI bn = do
+  bytes <- _bn2mpi (unwrapBN bn) nullPtr
+  allocaBytes (fromIntegral bytes) (\buffer -> do
+    _ <- _bn2mpi (unwrapBN bn) buffer
+    BS.packCStringLen (buffer, fromIntegral bytes))
+
diff --git a/testsuite/tests/llvm/should_compile/5681.hs b/testsuite/tests/llvm/should_compile/5681.hs
new file mode 100644
index 0000000000..8a94fb44ce
--- /dev/null
+++ b/testsuite/tests/llvm/should_compile/5681.hs
@@ -0,0 +1,14 @@
+{-# LANGUAGE MagicHash, UnboxedTuples #-}
+-- Test case for Trac #5681
+module Main where
+
+import GHC.Prim
+
+work :: Int -> Int
+work n = work (n-1)
+
+main :: IO ()
+main = case spark# (work 2) realWorld# of
+           (# _, _ #) -> case par# (work 1) of
+                             _ -> return ()
+
diff --git a/testsuite/tests/llvm/should_compile/all.T b/testsuite/tests/llvm/should_compile/all.T
index 8c90892078..fb3f07e481 100644
--- a/testsuite/tests/llvm/should_compile/all.T
+++ b/testsuite/tests/llvm/should_compile/all.T
@@ -7,4 +7,6 @@ setTestOpts(f)
 
 test('5054', reqlib('hmatrix'), compile, ['-package hmatrix'])
 test('5054_2', reqlib('hmatrix'), compile, ['-package hmatrix'])
+test('5486', normal, compile, [''])
+test('5681', normal, compile, [''])