content: {-# LANGUAGE CPP, MagicHash, BlockArguments, UnboxedTuples #-}
  
  -- Tests for the timesInt2# primop
  module Main ( main ) where
  
  import Data.Bits
  import GHC.Int
  import GHC.Exts
  import GHC.Word
  import Control.Monad
  
  #include "MachDeps.h"
  
  
  imul2 :: Int -> Int -> (Int,Int,Int)
  imul2 (I# x) (I# y) = case timesInt2# x y of
     (# c, h, l #) -> (I# c, I# h, I# l)
  
  checkImul2 :: Int -> Int -> IO ()
  checkImul2 x y = do
     -- First we compare against Integer result. Note that this test will become
     -- moot when Integer implementation will use this primitive
     let
        w2 = fromIntegral x * (fromIntegral y :: Integer)
        (c,h,l) = imul2 x y
        w = case c of
              0 -> fromIntegral l
              _ -> int2ToInteger h l
  
     unless (w == w2) do
        putStrLn $ mconcat
         [ "Failed: "
         , show x
         , " * "
         , show y
         , "\n    Got: "
         , show w
         , "\n    Expected: "
         , show w2
         ]
  
     -- Now we compare with a generic version using unsigned multiply.
     -- This reimplements the fallback generic version that the compiler uses when
     -- the mach-op isn't available so it'd better be correct too.
     let (c',h',l') = genericIMul2 x y
  
     unless ((c,h,l) == (c',h',l')) do
        putStrLn $ mconcat
         [ "Failed: "
         , show x
         , " * "
         , show y
         , "\n    Got: "
         , show (c,h,l)
         , "\n    Expected: "
         , show (c',h',l')
         ]
  
  addWordC :: Word -> Word -> (Word,Word)
  addWordC (W# x) (W# y) = case addWordC# x y of
     (# l,c #) -> (W# (int2Word# c), W# l)
  
  int2ToInteger :: Int -> Int -> Integer
  int2ToInteger h l
    | h < 0     = case addWordC (complement (fromIntegral l)) 1 of
                    (c,w) -> -1 * word2ToInteger (c + complement (fromIntegral h)) w
    | otherwise = word2ToInteger (fromIntegral h) (fromIntegral l)
    where
     word2ToInteger :: Word -> Word -> Integer
     word2ToInteger x y = (fromIntegral x) `shiftL` WORD_SIZE_IN_BITS + fromIntegral y
  
  timesWord2 :: Word -> Word -> (Int,Int)
  timesWord2 (W# x) (W# y) = case timesWord2# x y of
     (# h, l #) -> (I# (word2Int# h), I# (word2Int# l))
  
  genericIMul2 :: Int -> Int -> (Int,Int,Int)
  genericIMul2 x y = (c,h,l)
     where
        (p,l) = timesWord2 (fromIntegral x) (fromIntegral y)
        h = p - f x y - f y x
        c = if h == carryFill l then 0 else 1
        f u v = carryFill u .&. v
  
        -- Return either 00..00 or FF..FF depending on the carry
        carryFill :: Int -> Int
        carryFill x = x `shiftR` (WORD_SIZE_IN_BITS - 1)
  
  
  main = do
     checkImul2 10 10
     checkImul2 10 (-10)
     checkImul2 minBound (-1)
     checkImul2 maxBound (-1)
     checkImul2 minBound 0
     checkImul2 maxBound 0
     checkImul2 minBound minBound
     checkImul2 minBound maxBound
     checkImul2 maxBound maxBound
  