Update Trac ticket URLs to point to GitLab
[ghc.git] / testsuite / tests / llvm / should_compile / T5486.hs
1 {-# LANGUAGE ForeignFunctionInterface, UnliftedFFITypes, UnboxedTuples,
2 BangPatterns, MagicHash #-}
3
4 -- | Test case for #5486
5 -- Test case reduced from HsOpenSSL package BN module
6 module Bad where
7
8 import Control.Exception hiding (try)
9 import Foreign
10 import qualified Data.ByteString as BS
11
12 import Foreign.C.Types
13 import GHC.Base
14 import GHC.Integer.GMP.Internals
15
16 newtype BigNum = BigNum (Ptr BIGNUM)
17 data BIGNUM
18
19 data ByteArray = BA !ByteArray#
20 data MBA = MBA !(MutableByteArray# RealWorld)
21
22 foreign import ccall unsafe "BN_free"
23 _free :: Ptr BIGNUM -> IO ()
24
25 foreign import ccall unsafe "BN_bn2mpi"
26 _bn2mpi :: Ptr BIGNUM -> Ptr CChar -> IO CInt
27
28 foreign import ccall unsafe "memcpy"
29 _copy_in :: ByteArray# -> Ptr () -> CSize -> IO ()
30
31 foreign import ccall unsafe "memcpy"
32 _copy_out :: Ptr () -> ByteArray# -> CSize -> IO ()
33
34 unwrapBN :: BigNum -> Ptr BIGNUM
35 unwrapBN (BigNum p) = p
36
37 wrapBN :: Ptr BIGNUM -> BigNum
38 wrapBN = BigNum
39
40 bnToInteger :: BigNum -> IO Integer
41 bnToInteger bn = do
42 nlimbs <- ((\hsc_ptr -> peekByteOff hsc_ptr 8)) (unwrapBN bn) :: IO CInt
43 case nlimbs of
44 0 -> return 0
45 1 -> do (I# i) <- ((\hsc_ptr -> peekByteOff hsc_ptr 0)) (unwrapBN bn) >>= peek
46 negative <- ((\hsc_ptr -> peekByteOff hsc_ptr 16)) (unwrapBN bn) :: IO CInt
47 if negative == 0
48 then return $ S# i
49 else return $ 0 - (S# i)
50 _ -> do
51 let !(I# nlimbsi) = fromIntegral nlimbs
52 !(I# limbsize) = ((8))
53 (MBA arr) <- newByteArray (nlimbsi *# limbsize)
54 (BA ba) <- freezeByteArray arr
55 limbs <- ((\hsc_ptr -> peekByteOff hsc_ptr 0)) (unwrapBN bn)
56 _ <- _copy_in ba limbs $ fromIntegral $ nlimbs * ((8))
57 negative <- ((\hsc_ptr -> peekByteOff hsc_ptr 16)) (unwrapBN bn) :: IO CInt
58 if negative == 0
59 then return $ J# nlimbsi ba
60 else return $ 0 - (J# nlimbsi ba)
61
62 newByteArray :: Int# -> IO MBA
63 newByteArray sz = IO $ \s ->
64 case newByteArray# sz s of { (# s', arr #) ->
65 (# s', MBA arr #) }
66
67 freezeByteArray :: MutableByteArray# RealWorld -> IO ByteArray
68 freezeByteArray arr = IO $ \s ->
69 case unsafeFreezeByteArray# arr s of { (# s', arr' #) ->
70 (# s', BA arr' #) }
71
72 integerToBN :: Integer -> IO BigNum
73 integerToBN (S# 0#) = do
74 bnptr <- mallocBytes ((24))
75 ((\hsc_ptr -> pokeByteOff hsc_ptr 0)) bnptr nullPtr
76 let one :: CInt
77 one = 1
78 zero :: CInt
79 zero = 0
80 ((\hsc_ptr -> pokeByteOff hsc_ptr 20)) bnptr one
81 ((\hsc_ptr -> pokeByteOff hsc_ptr 8)) bnptr zero
82 ((\hsc_ptr -> pokeByteOff hsc_ptr 12)) bnptr zero
83 ((\hsc_ptr -> pokeByteOff hsc_ptr 16)) bnptr zero
84 return (wrapBN bnptr)
85
86 integerToBN (S# v) = do
87 bnptr <- mallocBytes ((24))
88 limbs <- malloc :: IO (Ptr CULong)
89 poke limbs $ fromIntegral $ abs $ I# v
90 ((\hsc_ptr -> pokeByteOff hsc_ptr 0)) bnptr limbs
91 let one :: CInt
92 one = 1
93 ((\hsc_ptr -> pokeByteOff hsc_ptr 20)) bnptr one
94 ((\hsc_ptr -> pokeByteOff hsc_ptr 8)) bnptr one
95 ((\hsc_ptr -> pokeByteOff hsc_ptr 12)) bnptr one
96 ((\hsc_ptr -> pokeByteOff hsc_ptr 16)) bnptr (if (I# v) < 0 then one else 0)
97 return (wrapBN bnptr)
98
99 integerToBN v@(J# nlimbs_ bytearray)
100 | v >= 0 = do
101 let nlimbs = (I# nlimbs_)
102 bnptr <- mallocBytes ((24))
103 limbs <- mallocBytes (((8)) * nlimbs)
104 ((\hsc_ptr -> pokeByteOff hsc_ptr 0)) bnptr limbs
105 ((\hsc_ptr -> pokeByteOff hsc_ptr 20)) bnptr (1 :: CInt)
106 _ <- _copy_out limbs bytearray (fromIntegral $ ((8)) * nlimbs)
107 ((\hsc_ptr -> pokeByteOff hsc_ptr 8)) bnptr ((fromIntegral nlimbs) :: CInt)
108 ((\hsc_ptr -> pokeByteOff hsc_ptr 12)) bnptr ((fromIntegral nlimbs) :: CInt)
109 ((\hsc_ptr -> pokeByteOff hsc_ptr 16)) bnptr (0 :: CInt)
110 return (wrapBN bnptr)
111 | otherwise = do bnptr <- integerToBN (0-v)
112 ((\hsc_ptr -> pokeByteOff hsc_ptr 16)) (unwrapBN bnptr) (1 :: CInt)
113 return bnptr
114
115 integerToMPI :: Integer -> IO BS.ByteString
116 integerToMPI v = bracket (integerToBN v) (_free . unwrapBN) bnToMPI
117
118 bnToMPI :: BigNum -> IO BS.ByteString
119 bnToMPI bn = do
120 bytes <- _bn2mpi (unwrapBN bn) nullPtr
121 allocaBytes (fromIntegral bytes) (\buffer -> do
122 _ <- _bn2mpi (unwrapBN bn) buffer
123 BS.packCStringLen (buffer, fromIntegral bytes))
124