ghc/tests/ccall/should_run/fed001.hs

   1 import Foreign
   2 import Monad
   3 import Addr
   4 import System
   5 import IO
   6
   7 import IOExts
   8 global :: a -> IORef a
   9 global a = unsafePerformIO (newIORef a)
  10 {-# NOINLINE global #-}
  11 v_NumCmps = global 0 :: IORef Int
  12 {-# NOINLINE v_NumCmps #-}
  13
  14 newtype XPtr a = XPtr Addr
  15 unXPtr (XPtr (A# x)) = x
  16
  17 type CInt  = Int32
  18 type CSize = Word32
  19
  20 foreign export dynamic
  21    mkComparator :: (XPtr Int -> XPtr Int -> IO CInt)
  22                 -> IO (XPtr (XPtr Int -> XPtr Int -> IO CInt))
  23
  24 foreign import
  25    qsort :: Ptr Int -> CSize -> CSize -> XPtr (XPtr Int -> XPtr Int -> IO CInt)
  26          -> IO ()
  27
  28 compareInts :: XPtr Int -> XPtr Int -> IO CInt
  29 compareInts a1 a2 = do
  30    num_cmps <- readIORef v_NumCmps
  31    if num_cmps < 100
  32     then
  33      do writeIORef v_NumCmps (num_cmps+1)
  34         i1 <- peek (Ptr (unXPtr a1))
  35         i2 <- peek (Ptr (unXPtr a2))
  36         return (fromIntegral (i1 - i2 :: Int))
  37     else
  38      do hPutStrLn stderr
  39                   "compareInts: 100 comparisons exceeded; something's wrong"
  40         exitWith (ExitFailure 1)
  41
  42 main :: IO ()
  43 main = do
  44    let values = [ 12, 56, 90, 34, 78 ] :: [Int]
  45        n      = length values
  46    buf <- mallocArray n
  47    zipWithM_ (pokeElemOff buf) [ 0 .. ] values
  48    c <- mkComparator compareInts
  49    qsort buf (fromIntegral n) (fromIntegral (sizeOf (head values))) c
  50    mapM (peekElemOff buf) [ 0 .. n-1 ] >>= (print :: [Int] -> IO ())