diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,30 @@ +Copyright Trevor L. McDonell (c) 2017 + +All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are met: + + * Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. + + * Redistributions in binary form must reproduce the above + copyright notice, this list of conditions and the following + disclaimer in the documentation and/or other materials provided + with the distribution. + + * Neither the name of Trevor L. McDonell nor the names of other + contributors may be used to endorse or promote products derived + from this software without specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT +LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR +A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT +OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, +SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT +LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, +DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY +THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. diff --git a/README.md b/README.md new file mode 100644 --- /dev/null +++ b/README.md @@ -0,0 +1,11 @@ +Big-number arithmetic for Accelerate +==================================== + +[![Build Status](https://travis-ci.org/tmcdonell/accelerate-bignum.svg)](https://travis-ci.org/tmcdonell/accelerate-bignum) + +This package provides fixed-length large integer types and arithmetic operations +for Accelerate. Signed and unsigned 96, 128, 160, 192, 224, 256, and 512-bit +types are predefined. + +For details on Accelerate refer to the [main repository](https://github.com/AccelerateHS/accelerate). + diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/accelerate-bignum.cabal b/accelerate-bignum.cabal new file mode 100644 --- /dev/null +++ b/accelerate-bignum.cabal @@ -0,0 +1,175 @@ +name: accelerate-bignum +version: 0.1.0.0 +synopsis: Fixed-length large integer arithmetic for Accelerate +description: + This package provides fixed-length large integer types and arithmetic + operations for Accelerate. Signed and unsigned 96, 128, 160, 192, 224, 256, + and 512-bit types are predefined. + . + Refer to the main /Accelerate/ package for more information: + + +homepage: https://github.com/tmcdonell/accelerate-bignum +bug-reports: https://github.com/tmcdonell/accelerate-bignum/issues +license: BSD3 +license-file: LICENSE +author: Trevor L. McDonell +maintainer: Trevor L. McDonell +copyright: BSD3 +category: Compilers/Interpreters, Concurrency, Data, Parallelism +build-type: Simple +extra-source-files: README.md +cabal-version: >= 1.10 + +flag llvm-cpu + description: Enable primpos for the LLVM CPU backend + default: True + +flag llvm-ptx + description: Enable primops for the LLVM PTX backend + default: True + +library + default-language: Haskell2010 + hs-source-dirs: src + exposed-modules: + Data.Array.Accelerate.Data.BigInt + Data.Array.Accelerate.Data.BigWord + + other-modules: + Data.Array.Accelerate.Internal.BigInt + Data.Array.Accelerate.Internal.BigWord + Data.Array.Accelerate.Internal.LLVM.Native + Data.Array.Accelerate.Internal.LLVM.PTX + Data.Array.Accelerate.Internal.Num2 + Data.Array.Accelerate.Internal.Orphans + Data.Array.Accelerate.Internal.Orphans.Base + Data.Array.Accelerate.Internal.Orphans.Elt + + build-depends: + base >= 4.8 && < 4.10 + , ghc-prim + , template-haskell + , accelerate == 1.0.* + + if flag(llvm-cpu) + cpp-options: -DACCELERATE_LLVM_NATIVE_BACKEND + build-depends: + accelerate-llvm == 1.0.* + , accelerate-llvm-native == 1.0.* + , llvm-hs-pure >= 3.9 + -- + other-modules: + Data.Array.Accelerate.Internal.LLVM.Prim + + if flag(llvm-ptx) + cpp-options: -DACCELERATE_LLVM_PTX_BACKEND + build-depends: + accelerate-llvm == 1.0.* + , accelerate-llvm-ptx == 1.0.* + , llvm-hs-pure >= 3.9 + -- + other-modules: + Data.Array.Accelerate.Internal.LLVM.Prim + + ghc-options: + -O2 + -Wall + -fwarn-tabs + + cpp-options: + -DUNBOXED_TUPLES=1 + + if impl(ghc == 8.0.1) + -- https://ghc.haskell.org/trac/ghc/ticket/12212 + ghc-options: + -O0 + + +test-suite accelerate-bignum-test + default-language: Haskell2010 + type: exitcode-stdio-1.0 + hs-source-dirs: test + main-is: Main.hs + + build-depends: + base >= 4.8 && < 4.10 + , accelerate >= 0.16 + , accelerate-bignum + , tasty + , tasty-quickcheck + + ghc-options: + -O2 + -Wall + -threaded + -rtsopts + -fno-liberate-case + -funfolding-use-threshold=200 + -with-rtsopts=-N + -with-rtsopts=-n2M + -with-rtsopts=-A64M + + if flag(llvm-cpu) + cpp-options: -DACCELERATE_LLVM_NATIVE_BACKEND + build-depends: + accelerate-llvm-native + + if flag(llvm-ptx) + cpp-options: -DACCELERATE_LLVM_PTX_BACKEND + build-depends: + accelerate-llvm-ptx + +benchmark accelerate-bignum-bench + default-language: Haskell2010 + type: exitcode-stdio-1.0 + hs-source-dirs: bench + main-is: Main.hs + other-modules: + Accelerate + WideWord + + build-depends: + base >= 4.8 && < 4.10 + , accelerate + , accelerate-bignum + , accelerate-io >= 0.16 + , criterion >= 1.0 + , mwc-random >= 0.13 + , vector >= 0.11 + , vector-th-unbox >= 0.2 + , wide-word == 0.1.* + + ghc-options: + -O2 + -Wall + -threaded + -rtsopts + -fno-liberate-case + -funfolding-use-threshold=200 + -- -with-rtsopts=-N + -- -with-rtsopts=-n2M + -- -with-rtsopts=-A64M + + if flag(llvm-cpu) + cpp-options: -DACCELERATE_LLVM_NATIVE_BACKEND + build-depends: + accelerate-llvm-native + + if flag(llvm-ptx) + cpp-options: -DACCELERATE_LLVM_PTX_BACKEND + build-depends: + accelerate-llvm-ptx + + +source-repository head + type: git + location: https://github.com/tmcdonell/accelerate-bignum + +source-repository this + type: git + tag: 0.1.0.0 + location: https://github.com/tmcdonell/accelerate-bignum + +-- vim: nospell + diff --git a/bench/Accelerate.hs b/bench/Accelerate.hs new file mode 100644 --- /dev/null +++ b/bench/Accelerate.hs @@ -0,0 +1,154 @@ +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} + +module Accelerate where + +import Data.Array.Accelerate as A +import Data.Array.Accelerate.IO +import Data.Array.Accelerate.Data.Bits as A +import Data.Array.Accelerate.Data.BigWord +import Data.Array.Accelerate.Data.BigInt + +import Criterion.Main +import Data.Proxy +import Prelude ( String, Show(..), undefined ) +import Text.Printf +import qualified Data.Bits as P +import qualified Data.Vector.Unboxed as U +import qualified Prelude as P + + +benchmark + :: String + -> (forall a b. (Arrays a, Arrays b) => (Acc a -> Acc b) -> a -> b) + -> U.Vector Word64 + -> U.Vector Word64 + -> U.Vector Word64 + -> U.Vector Word64 + -> U.Vector Int + -> Benchmark +benchmark backend run1 xhi xlo yhi ylo ss = + bgroup backend + [ bench_word128 run1 xhi xlo yhi ylo ss + , bench_int128 run1 xhi xlo yhi ylo ss + ] + +bench_word128 + :: (forall a b. (Arrays a, Arrays b) => (Acc a -> Acc b) -> a -> b) + -> U.Vector Word64 + -> U.Vector Word64 + -> U.Vector Word64 + -> U.Vector Word64 + -> U.Vector Int + -> Benchmark +bench_word128 run1 xhi xlo yhi ylo ss = + let + n = U.length xhi + xs = fromVectors (Z :. n) (((), U.convert xhi), U.convert xlo) :: Vector Word128 + ys = fromVectors (Z :. n) (((), U.convert yhi), U.convert ylo) :: Vector Word128 + -- + ss' = fromVectors (Z :. U.length ss) (U.convert ss) :: Vector Int + sa' = fromVectors (Z :. U.length ss) (U.convert (U.map abs ss)) :: Vector Int + in + mkBench run1 xs ys ss' sa' + +bench_int128 + :: (forall a b. (Arrays a, Arrays b) => (Acc a -> Acc b) -> a -> b) + -> U.Vector Word64 + -> U.Vector Word64 + -> U.Vector Word64 + -> U.Vector Word64 + -> U.Vector Int + -> Benchmark +bench_int128 run1 xhi xlo yhi ylo ss = + let + n = U.length xhi + xs = fromVectors (Z :. n) (((), U.convert (U.map P.fromIntegral xhi)), U.convert xlo) :: Vector Int128 + ys = fromVectors (Z :. n) (((), U.convert (U.map P.fromIntegral yhi)), U.convert ylo) :: Vector Int128 + -- + ss' = fromVectors (Z :. U.length ss) (U.convert ss) :: Vector Int + sa' = fromVectors (Z :. U.length ss) (U.convert (U.map abs ss)) :: Vector Int + in + mkBench run1 xs ys ss' sa' + + +mkBench + :: forall t. (Show (ArgType t), Elt t, Eq t, Ord t, Num t, Integral t, Bits t, FiniteBits t) + => (forall a b. (Arrays a, Arrays b) => (Acc a -> Acc b) -> a -> b) + -> Vector t + -> Vector t + -> Vector Int + -> Vector Int + -> Benchmark +mkBench run1 !xs !ys !ss !sa = + let + xs' = use xs + ys' = use ys + in + bgroup (showType (Proxy::Proxy t)) + [ bgroup "Eq" + [ bench "(==)" $ whnf (run1 $ zipWith (==) xs') ys + , bench "(/=)" $ whnf (run1 $ zipWith (/=) xs') ys + ] + , bgroup "Ord" + [ bench "(>=)" $ whnf (run1 $ zipWith (>=) xs') ys + , bench "(<=)" $ whnf (run1 $ zipWith (<=) xs') ys + , bench "(>)" $ whnf (run1 $ zipWith (>) xs') ys + , bench "(<)" $ whnf (run1 $ zipWith (<) xs') ys + ] + , bgroup "Num" + [ bench "(+)" $ whnf (run1 $ zipWith (+) xs') ys + , bench "(-)" $ whnf (run1 $ zipWith (-) xs') ys + , bench "(*)" $ whnf (run1 $ zipWith (*) xs') ys + , bench "negate" $ whnf (run1 $ map negate) xs + , bench "abs" $ whnf (run1 $ map abs) ys + , bench "signum" $ whnf (run1 $ map signum) xs + ] + , bgroup "Integral" + [ bench "quot" $ whnf (run1 $ zipWith quot xs') ys + , bench "rem" $ whnf (run1 $ zipWith rem xs') ys + , bench "quotRem" $ whnf (run1 $ zipWith (lift $$ quotRem) xs') ys + , bench "div" $ whnf (run1 $ zipWith div xs') ys + , bench "mod" $ whnf (run1 $ zipWith mod xs') ys + , bench "divMod" $ whnf (run1 $ zipWith (lift $$ divMod) xs') ys + ] + , bgroup "Bits" + [ bench "(.&.)" $ whnf (run1 $ zipWith (.&.) xs') ys + , bench "(.|.)" $ whnf (run1 $ zipWith (.|.) xs') ys + , bench "xor" $ whnf (run1 $ zipWith xor xs') ys + , bench "complement" $ whnf (run1 $ map complement) xs + , bench "shift" $ whnf (run1 $ zipWith shift xs') ss + , bench "rotate" $ whnf (run1 $ zipWith rotate ys') ss + , bench "setBit" $ whnf (run1 $ zipWith setBit xs') sa + , bench "clearBit" $ whnf (run1 $ zipWith clearBit ys') sa + , bench "complementBit" $ whnf (run1 $ zipWith complementBit xs') sa + , bench "testBit" $ whnf (run1 $ zipWith testBit ys') sa + , bench "popCount" $ whnf (run1 $ map popCount) xs + ] + , bgroup "FiniteBits" + [ bench "countLeadingZeros" $ whnf (run1 $ map countLeadingZeros) xs + , bench "countTrailingZeros" $ whnf (run1 $ map countTrailingZeros) ys + ] + ] + + +infixr 0 $$ +($$) :: (b -> a) -> (c -> d -> b) -> c -> d -> a +(f $$ g) x y = f (g x y) + + +data ArgType (a :: *) = AT + +showType :: forall proxy a. Show (ArgType a) => proxy a -> String +showType _ = show (AT :: ArgType a) + +instance P.FiniteBits (BigWord a b) => Show (ArgType (BigWord a b)) where + show _ = printf "Word%d" (P.finiteBitSize (undefined::BigWord a b)) + +instance P.FiniteBits (BigInt a b) => Show (ArgType (BigInt a b)) where + show _ = printf "Int%d" (P.finiteBitSize (undefined::BigInt a b)) + diff --git a/bench/Main.hs b/bench/Main.hs new file mode 100644 --- /dev/null +++ b/bench/Main.hs @@ -0,0 +1,52 @@ +{-# LANGUAGE CPP #-} + +module Main where + +import Control.Applicative +import Criterion.Main +import Data.Maybe +import Data.Vector.Unboxed ( Vector ) +import Data.Word +import System.Random.MWC +import qualified Data.Vector.Unboxed as U +import Prelude as P + +import qualified WideWord +import qualified Accelerate +#if ACCELERATE_LLVM_NATIVE_BACKEND +import qualified Data.Array.Accelerate.LLVM.Native as CPU +#endif +#if ACCELERATE_LLVM_PTX_BACKEND +import qualified Data.Array.Accelerate.LLVM.PTX as PTX +#endif + + +lIMIT :: Int +lIMIT = 1000000 + +generateData :: IO (Vector Word64, Vector Word64, Vector Word64, Vector Word64, Vector Int) +generateData = + withSystemRandom . asGenIO $ \gen -> + (,,,,) <$> uniformVector gen lIMIT + <*> uniformVector gen lIMIT + <*> uniformVector gen lIMIT + <*> uniformVector gen lIMIT + <*> U.replicateM lIMIT (uniformR (-64,64) gen) + +main :: IO () +main = do + (xh,xl,yh,yl,ss) <- generateData + defaultMain + [ WideWord.benchmark xh xl yh yl ss + , bgroup "accelerate" + $ catMaybes + [ Nothing +#if ACCELERATE_LLVM_NATIVE_BACKEND + , Just $ Accelerate.benchmark "llvm-cpu" CPU.run1 xh xl yh yl ss +#endif +#if ACCELERATE_LLVM_PTX_BACKEND + , Just $ Accelerate.benchmark "llvm-ptx" PTX.run1 xh xl yh yl ss +#endif + ] + ] + diff --git a/bench/WideWord.hs b/bench/WideWord.hs new file mode 100644 --- /dev/null +++ b/bench/WideWord.hs @@ -0,0 +1,110 @@ +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TypeFamilies #-} +{-# OPTIONS_GHC -fno-warn-orphans #-} + +module WideWord where + +import Data.Word +import Data.Bits +import Data.WideWord.Int128 +import Data.WideWord.Word128 + +import Criterion.Main +import Data.Vector.Unboxed ( Vector, Unbox ) +import Data.Vector.Unboxed.Deriving +import qualified Data.Vector.Unboxed as U + + +-- This is the easiest to implement, but not entirely correct; we should keep +-- the structure packed in memory so that the hi and lo words are adjacent. I'll +-- leave @erikd to implement that though... + +derivingUnbox "Word128" + [t| Word128 -> (Word64, Word64) |] + [| \(Word128 hi lo) -> (hi,lo) |] + [| \(hi,lo) -> Word128 hi lo |] + +derivingUnbox "Int128" + [t| Int128 -> (Word64, Word64) |] + [| \(Int128 hi lo) -> (hi,lo) |] + [| \(hi,lo) -> Int128 hi lo |] + + +benchmark + :: Vector Word64 + -> Vector Word64 + -> Vector Word64 + -> Vector Word64 + -> Vector Int + -> Benchmark +benchmark !xhi !xlo !yhi !ylo !ss = + bgroup "WideWord" + [ mkBench "Word128" Word128 xhi xlo yhi ylo ss + , mkBench "Int128" Int128 xhi xlo yhi ylo ss + ] + + +mkBench + :: (Unbox t, Eq t, Ord t, Num t, Integral t, Bits t, FiniteBits t) + => String + -> (Word64 -> Word64 -> t) + -> Vector Word64 + -> Vector Word64 + -> Vector Word64 + -> Vector Word64 + -> Vector Int + -> Benchmark +mkBench ty con xhi xlo yhi ylo ss = + let + xs = U.zipWith con xhi xlo + ys = U.zipWith con yhi ylo + ss' = U.map abs ss + in + bgroup ty + [ bgroup "Eq" + [ bench "(==)" $ nf (U.zipWith (==) xs) ys + , bench "(/=)" $ nf (U.zipWith (/=) xs) ys + ] + , bgroup "Ord" + [ bench "(>=)" $ nf (U.zipWith (>=) xs) ys + , bench "(<=)" $ nf (U.zipWith (<=) xs) ys + , bench "(>)" $ nf (U.zipWith (>) xs) ys + , bench "(<)" $ nf (U.zipWith (<) xs) ys + ] + , bgroup "Num" + [ bench "(+)" $ nf (U.zipWith (+) xs) ys + , bench "(-)" $ nf (U.zipWith (-) xs) ys + , bench "(*)" $ nf (U.zipWith (*) xs) ys + , bench "negate" $ nf (U.map negate) xs + , bench "abs" $ nf (U.map abs) ys + , bench "signum" $ nf (U.map signum) xs + ] + , bgroup "Integral" + [ bench "quot" $ nf (U.zipWith quot xs) ys + , bench "rem" $ nf (U.zipWith rem xs) ys + , bench "quotRem" $ nf (U.zipWith quotRem xs) ys + , bench "div" $ nf (U.zipWith div xs) ys + , bench "mod" $ nf (U.zipWith mod xs) ys + , bench "divMod" $ nf (U.zipWith divMod xs) ys + ] + , bgroup "Bits" + [ bench "(.&.)" $ nf (U.zipWith (.&.) xs) ys + , bench "(.|.)" $ nf (U.zipWith (.|.) xs) ys + , bench "xor" $ nf (U.zipWith xor xs) ys + , bench "complement" $ nf (U.map complement) xs + , bench "shift" $ nf (U.zipWith shift xs) ss + , bench "rotate" $ nf (U.zipWith rotate ys) ss + , bench "setBit" $ nf (U.zipWith setBit xs) ss' + , bench "clearBit" $ nf (U.zipWith clearBit ys) ss' + , bench "complementBit" $ nf (U.zipWith complementBit xs) ss' + , bench "testBit" $ nf (U.zipWith testBit ys) ss' + , bench "popCount" $ nf (U.map popCount) xs + ] + , bgroup "FiniteBits" + [ bench "countLeadingZeros" $ nf (U.map countLeadingZeros) xs + , bench "countTrailingZeros" $ nf (U.map countTrailingZeros) ys + ] + ] + diff --git a/src/Data/Array/Accelerate/Data/BigInt.hs b/src/Data/Array/Accelerate/Data/BigInt.hs new file mode 100644 --- /dev/null +++ b/src/Data/Array/Accelerate/Data/BigInt.hs @@ -0,0 +1,32 @@ +-- | +-- Module : Data.Array.Accelerate.Data.BigInt +-- Copyright : [2016] Trevor L. McDonell +-- License : BSD3 +-- +-- Maintainer : Trevor L. McDonell +-- Stability : experimental +-- Portability : non-portable (GHC extensions) +-- +-- Fixed length signed integer types +-- + +module Data.Array.Accelerate.Data.BigInt ( + + Int96, + Int128, + Int160, + Int192, + Int224, + Int256, + Int512, + + -- ** Internals + BigInt(..), + Num2(..) + +) where + +import Data.Array.Accelerate.Internal.Num2 +import Data.Array.Accelerate.Internal.BigInt +import Data.Array.Accelerate.Internal.Orphans () + diff --git a/src/Data/Array/Accelerate/Data/BigWord.hs b/src/Data/Array/Accelerate/Data/BigWord.hs new file mode 100644 --- /dev/null +++ b/src/Data/Array/Accelerate/Data/BigWord.hs @@ -0,0 +1,31 @@ +-- | +-- Module : Data.Array.Accelerate.Data.BigWord +-- Copyright : [2016] Trevor L. McDonell +-- License : BSD3 +-- +-- Maintainer : Trevor L. McDonell +-- Stability : experimental +-- Portability : non-portable (GHC extensions) +-- +-- Fixed length unsigned word types + +module Data.Array.Accelerate.Data.BigWord ( + + Word96, + Word128, + Word160, + Word192, + Word224, + Word256, + Word512, + + -- ** Internals + BigWord(..), + Num2(..), + +) where + +import Data.Array.Accelerate.Internal.Num2 +import Data.Array.Accelerate.Internal.BigWord +import Data.Array.Accelerate.Internal.Orphans () + diff --git a/src/Data/Array/Accelerate/Internal/BigInt.hs b/src/Data/Array/Accelerate/Internal/BigInt.hs new file mode 100644 --- /dev/null +++ b/src/Data/Array/Accelerate/Internal/BigInt.hs @@ -0,0 +1,319 @@ +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE UndecidableInstances #-} +-- | +-- Module : Data.Array.Accelerate.Internal.BigInt +-- Copyright : [2016] Trevor L. McDonell +-- License : BSD3 +-- +-- Maintainer : Trevor L. McDonell +-- Stability : experimental +-- Portability : non-portable (GHC extensions) +-- +-- Fixed length signed integer types +-- + +-- Based on the following (BSD3) projects: +-- * https://github.com/mvv/data-bword +-- * https://github.com/mvv/data-dword +-- + +module Data.Array.Accelerate.Internal.BigInt ( + + Int96, + Int128, + Int160, + Int192, + Int224, + Int256, + Int512, + + BigInt(..) + +) where + +import Data.Bits +import Data.Int +import Data.Ratio +import Data.Word + +import Data.Array.Accelerate.Internal.BigWord +import Data.Array.Accelerate.Internal.Num2 + + +type Int96 = BigInt Int32 Word64 +type Int128 = BigInt Int64 Word64 +type Int160 = BigInt Int32 Word128 +type Int192 = BigInt Int64 Word128 +type Int224 = BigInt Int32 Word192 +type Int256 = BigInt Int128 Word128 +type Int512 = BigInt Int256 Word256 + + +-- | Large integers of fixed size represented as separate (signed) high and +-- (unsigned) low words. +-- +data BigInt hi lo = I2 !hi !lo +type BigIntCtx hi lo = (hi ~ Signed hi, lo ~ Unsigned lo, Signed (Unsigned hi) ~ hi) + + +instance Integral (BigInt a b) => Show (BigInt a b) where + show = show . toInteger + + +instance (Bounded a, Bounded b) => Bounded (BigInt a b) where + minBound = I2 minBound minBound + maxBound = I2 maxBound maxBound + + +instance (Enum a, Num a, Eq a, Enum b, Num b, Eq b, Bounded b) + => Enum (BigInt a b) where + succ (I2 hi lo) + | lo == maxBound = I2 (succ hi) minBound + | otherwise = I2 hi (succ lo) + + pred (I2 hi lo) + | lo == minBound = I2 (pred hi) maxBound + | otherwise = I2 hi (pred lo) + + toEnum x + | x < 0 = I2 (-1) (negate (1 + toEnum (negate (x+1)))) + | otherwise = I2 0 (toEnum x) + + fromEnum (I2 0 lo) = fromEnum lo + fromEnum (I2 (-1) lo) = negate (fromEnum (negate lo)) + fromEnum _ = error "Enum.fromEnum: bad value" + + +instance (Ord a, Ord b) => Ord (BigInt a b) where + compare (I2 xh xl) (I2 yh yl) = + case compare xh yh of + EQ -> compare xl yl + r -> r + + +instance (Eq a, Eq b) => Eq (BigInt a b) where + I2 xh xl == I2 yh yl = xh == yh && xl == yl + I2 xh xl /= I2 yh yl = xh /= yh || xl /= yl + + +instance ( Integral a, Ord a + , Integral b, Ord b, Bounded b + , Ord (BigInt a b) + , Num (BigInt a b) + , Num2 (BigInt a b) + , Num (BigWord (Unsigned a) b) + , Num2 (BigWord (Unsigned a) b) + , BigIntCtx a b + ) + => Num (BigInt a b) where + negate (I2 hi lo) + | lo == 0 = I2 (negate hi) 0 + | otherwise = I2 (negate (hi+1)) (negate lo) + + abs x + | x < 0 = negate x + | otherwise = x + + signum (I2 hi lo) = + case compare hi 0 of + LT -> I2 (-1) maxBound + EQ -> if lo == 0 then 0 else 1 + GT -> I2 0 1 + + I2 xh xl + I2 yh yl = I2 hi lo + where + lo = xl + yl + hi = xh + yh + if lo < xl then 1 else 0 + + x * y = signed (unsigned x * unsigned y) + + fromInteger x = I2 (fromInteger hi) (fromInteger lo) + where + (hi,lo) = x `divMod` (toInteger (maxBound::b) + 1) + + +instance ( Integral a + , Integral b, Bounded b + , Integral (BigWord (Unsigned a) b) + , Num2 (BigInt a b) + , Num2 (BigWord (Unsigned a) b) + , BigIntCtx a b + ) + => Integral (BigInt a b) where + toInteger (I2 hi lo) = + toInteger hi * (toInteger (maxBound::b) + 1) + toInteger lo + + quotRem x y = + if x < 0 + then if y < 0 + then + let (q,r) = quotRem (negate (unsigned x)) (negate (unsigned y)) + in (signed q, signed (negate r)) + else + let (q,r) = quotRem (negate (unsigned x)) (unsigned y) + in (signed (negate q), signed (negate r)) + else if y < 0 + then + let (q,r) = quotRem (unsigned x) (negate (unsigned y)) + in (signed (negate q), signed r) + else + let (q,r) = quotRem (unsigned x) (unsigned y) + in (signed q, signed r) + + divMod x y = + if x < 0 + then if y < 0 + then let (q,r) = quotRem (negate (unsigned x)) (negate (unsigned y)) + in (signed q, signed (negate r)) + else let (q,r) = quotRem (negate (unsigned x)) (unsigned y) + q' = signed (negate q) + r' = signed (negate r) + in + if r == 0 then (q', r') + else (q'-1, r'+y) + else if y < 0 + then let (q,r) = quotRem (unsigned x) (negate (unsigned y)) + q' = signed (negate q) + r' = signed r + in + if r == 0 + then (q', r') + else (q'-1, r'+y) + else let (q,r) = quotRem (unsigned x) (unsigned y) + in (signed q, signed r) + + +instance (Integral (BigInt a b), Num (BigInt a b), Ord (BigInt a b)) + => Real (BigInt a b) where + toRational x = toInteger x % 1 + + +instance ( Ord a + , Num a + , Num2 a + , Num (BigInt a b) + , Ord (BigInt a b) + , Num2 (BigInt a b) + , Bits (BigInt a b) + , Num (BigWord (Unsigned a) b) + , Num2 (BigWord (Unsigned a) b) + , Bounded (BigWord (Unsigned a) b) + , BigIntCtx a b + , Unsigned (Unsigned a) ~ Unsigned a + ) + => Num2 (BigInt a b) where + type Signed (BigInt a b) = BigInt (Signed a) b + type Unsigned (BigInt a b) = BigWord (Unsigned a) b + -- + signed = id + unsigned (I2 hi lo) = W2 (unsigned hi) lo + -- + addWithCarry x y = (c, r) + where + t1 = if x < 0 then maxBound else minBound + t2 = if y < 0 then maxBound else minBound + (t3, r) = addWithCarry (unsigned x) (unsigned y) + c = signed (t1+t2+t3) + + mulWithCarry x@(I2 xh _) y@(I2 yh _) = (hi,lo) + where + t1 = complement y + 1 + t2 = complement x + 1 + (t3, lo) = mulWithCarry (unsigned x) (unsigned y) + t4 = signed t3 + hi = if xh < 0 + then if yh < 0 + then t4 + t1 + t2 + else t4 + t1 + else if yh < 0 + then t4 + t2 + else t4 + + +instance ( FiniteBits a, Integral a + , FiniteBits b, Integral b + , FiniteBits (BigInt a b) + , Num2 (BigInt a b) + , Num2 (BigWord (Unsigned a) b) + , Bits (BigWord (Unsigned a) b) + , Integral (Signed b), Bits (Signed b) + , BigIntCtx a b + ) + => Bits (BigInt a b) where + isSigned _ = True + bitSize = finiteBitSize + bitSizeMaybe = Just . finiteBitSize + + I2 xh xl .&. I2 yh yl = I2 (xh .&. yh) (xl .&. yl) + I2 xh xl .|. I2 yh yl = I2 (xh .|. yh) (xl .|. yl) + I2 xh xl `xor` I2 yh yl = I2 (xh `xor` yh) (xl `xor` yl) + complement (I2 hi lo) = I2 (complement hi) (complement lo) + + shiftL (I2 hi lo) x + | y > 0 = I2 (shiftL hi x .|. fromIntegral (shiftR lo y)) (shiftL lo x) + | otherwise = I2 (fromIntegral (shiftL lo (negate y))) 0 + where + y = finiteBitSize (undefined::b) - x + + shiftR (I2 hi lo) x = I2 hi' lo' + where + hi' = shiftR hi x + lo' | y >= 0 = shiftL (fromIntegral hi) y .|. shiftR lo x + | otherwise = z + -- + y = finiteBitSize (undefined::b) - x + z = fromIntegral (shiftR (fromIntegral hi :: Signed b) (negate y)) + + rotateL x y = signed (rotateL (unsigned x) y) + rotateR x y = rotateL x (finiteBitSize (undefined::BigInt a b) - y) + + bit n + | m >= 0 = I2 (bit m) 0 + | otherwise = I2 0 (bit n) + where + m = n - finiteBitSize (undefined::b) + + testBit (I2 hi lo) n + | m >= 0 = testBit hi m + | otherwise = testBit lo n + where + m = n - finiteBitSize (undefined::b) + + setBit (I2 hi lo) n + | m >= 0 = I2 (setBit hi m) lo + | otherwise = I2 hi (setBit lo n) + where + m = n - finiteBitSize (undefined::b) + + clearBit (I2 hi lo) n + | m >= 0 = I2 (clearBit hi m) lo + | otherwise = I2 hi (clearBit lo n) + where + m = n - finiteBitSize (undefined::b) + + complementBit (I2 hi lo) n + | m >= 0 = I2 (complementBit hi m) lo + | otherwise = I2 hi (complementBit lo n) + where + m = n - finiteBitSize (undefined::b) + + popCount (I2 hi lo) = popCount hi + popCount lo + + +instance ( FiniteBits a + , FiniteBits b + , Bits (BigInt a b) + , Num2 (BigInt a b) + , FiniteBits (BigWord (Unsigned a) b) + , BigIntCtx a b + ) + => FiniteBits (BigInt a b) where + finiteBitSize _ = finiteBitSize (undefined::a) + + finiteBitSize (undefined::b) + + countLeadingZeros = countLeadingZeros . unsigned + countTrailingZeros = countTrailingZeros . unsigned + diff --git a/src/Data/Array/Accelerate/Internal/BigInt.hs-boot b/src/Data/Array/Accelerate/Internal/BigInt.hs-boot new file mode 100644 --- /dev/null +++ b/src/Data/Array/Accelerate/Internal/BigInt.hs-boot @@ -0,0 +1,18 @@ +-- | +-- Module : Data.Array.Accelerate.Internal.BigInt-boot +-- Copyright : [2016] Trevor L. McDonell +-- License : BSD3 +-- +-- Maintainer : Trevor L. McDonell +-- Stability : experimental +-- Portability : non-portable (GHC extensions) +-- + +module Data.Array.Accelerate.Internal.BigInt + where + +-- | Large integers of fixed size represented as separate (signed) high and +-- (unsigned) low words. +-- +data BigInt hi lo = I2 !hi !lo + diff --git a/src/Data/Array/Accelerate/Internal/BigWord.hs b/src/Data/Array/Accelerate/Internal/BigWord.hs new file mode 100644 --- /dev/null +++ b/src/Data/Array/Accelerate/Internal/BigWord.hs @@ -0,0 +1,372 @@ +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE UndecidableInstances #-} +-- | +-- Module : Data.Array.Accelerate.Internal.BigWord +-- Copyright : [2016] Trevor L. McDonell +-- License : BSD3 +-- +-- Maintainer : Trevor L. McDonell +-- Stability : experimental +-- Portability : non-portable (GHC extensions) +-- +-- Fixed length unsigned word types + +-- Based on the following (BSD3) projects: +-- * https://github.com/mvv/data-bword +-- * https://github.com/mvv/data-dword +-- + +-- TLM: This generic setup allows us to define instances recursively, but for +-- better performance in pure Haskell, specialised instances with unpacked +-- fields (esp for >128 bits) would probably be better. This makes no +-- difference for Accelerate though which is unboxed and hyper strict. + + +module Data.Array.Accelerate.Internal.BigWord ( + + Word96, + Word128, + Word160, + Word192, + Word224, + Word256, + Word512, + + BigWord(..) + +) where + +import Data.Bits +import Data.Ratio +import Data.Word + +import {-# SOURCE #-} Data.Array.Accelerate.Internal.BigInt +import Data.Array.Accelerate.Internal.Num2 + + +type Word96 = BigWord Word32 Word64 +type Word128 = BigWord Word64 Word64 +type Word160 = BigWord Word32 Word128 +type Word192 = BigWord Word64 Word128 +type Word224 = BigWord Word32 Word192 +type Word256 = BigWord Word128 Word128 +type Word512 = BigWord Word256 Word256 + + +-- | Large word of fixed size represented as separate high and low (unsigned) +-- words. +-- +data BigWord hi lo = W2 !hi !lo +type BigWordCtx hi lo = (hi ~ Unsigned hi, lo ~ Unsigned lo) + + +instance Integral (BigWord a b) => Show (BigWord a b) where + show = show . toInteger + + +instance (Bounded a, Bounded b) => Bounded (BigWord a b) where + minBound = W2 minBound minBound + maxBound = W2 maxBound maxBound + + +instance (Num a, Enum a, Bits a, Num b, Enum b, Bounded b, Eq b) + => Enum (BigWord a b) where + succ (W2 hi lo) + | lo == maxBound = W2 (succ hi) minBound + | otherwise = W2 hi (succ lo) + pred (W2 hi lo) + | lo == minBound = W2 (pred hi) maxBound + | otherwise = W2 hi (pred lo) + toEnum x + | x < 0 = error "Enum.toEnum: negative value" + | otherwise = W2 0 (toEnum x) + + fromEnum (W2 0 lo) = fromEnum lo + fromEnum _ = error "Enum.fromEnum: bad value" + + +instance (Ord a, Ord b) => Ord (BigWord a b) where + compare (W2 xh xl) (W2 yh yl) = + case compare xh yh of + EQ -> compare xl yl + r -> r + + +instance (Eq a, Eq b) => Eq (BigWord a b) where + W2 xh xl == W2 yh yl = xh == yh && xl == yl + W2 xh xl /= W2 yh yl = xh /= yh || xl /= yl + + +instance (Num a, Eq a, Integral b, Bounded b, Num2 b, BigWordCtx a b) + => Num (BigWord a b) where + negate (W2 hi lo) + | lo == 0 = W2 (negate hi) 0 + | otherwise = W2 (negate (hi+1)) (negate lo) + + abs = id + + signum (W2 0 0) = W2 0 0 + signum _ = W2 0 1 + + W2 xh xl + W2 yh yl = W2 hi lo + where + lo = xl + yl + hi = xh + yh + if lo < xl then 1 + else 0 + + W2 xh xl * W2 yh yl = W2 hi lo + where + hi = xh * fromIntegral yl + yh * fromIntegral xl + fromIntegral c + (c,lo) = mulWithCarry xl yl + + fromInteger x = W2 (fromInteger hi) (fromInteger lo) + where + (hi,lo) = x `divMod` (toInteger (maxBound :: b) + 1) + + +instance (Integral (BigWord a b), Num (BigWord a b), Ord (BigWord a b)) + => Real (BigWord a b) where + toRational x = toInteger x % 1 + + +instance ( Integral a, FiniteBits a, Num2 a, Bounded a + , Integral b, FiniteBits b, Num2 b, Bounded b + , BigWordCtx a b + ) + => Integral (BigWord a b) where + toInteger (W2 hi lo) = + toInteger hi * (toInteger (maxBound :: b) + 1) + toInteger lo + + divMod = quotRem + + quotRem x@(W2 xh xl) y@(W2 yh yl) + | yh == 0 && yl == 0 = error "divide by zero" + | otherwise = + case compare xh yh of + LT -> (0, x) + EQ -> case compare xl yl of + LT -> (0, x) + EQ -> (1, 0) + GT | yh == 0 -> + let (t2, t1) = quotRem xl yl + in (W2 0 t2, W2 0 t1) + GT -> (1, W2 0 (xl - yl)) + + GT | yl == 0 + -> let (t2, t1) = quotRem xh yh + in (W2 0 (fromIntegral t2), W2 t1 xl) + + GT | yh == 0 && yl == maxBound + -> let z = fromIntegral xh + (t2, t1) = addWithCarry z xl + in + if t2 == 0 + then if t1 == maxBound + then ((W2 0 z) + 1, 0) + else (W2 0 z, W2 0 t1) + else if t1 == maxBound + then ((W2 0 z) + 2, 1) + else if t1 == xor maxBound 1 + then ((W2 0 z) + 2, 0) + else ((W2 0 z) + 1, W2 0 (t1 + 1)) + + + GT | yh == 0 + -> let (t2, t1) = div1 xh xl yl + in (t2, W2 0 t1) + + GT | t1 == t2 -> (1, x - y) + | otherwise -> (W2 0 (fromIntegral q2), shiftR r2 t2) + where + t1 = countLeadingZeros xh + t2 = countLeadingZeros yh + z = shiftR xh (finiteBitSize (undefined::a) - t2) + W2 hhh hll = shiftL x t2 + v@(W2 lhh lll) = shiftL y t2 + -- z hhh hll / lhh lll + ((0, q1), r1) = div2 z hhh lhh + (t4, t3) = mulWithCarry (fromIntegral q1) lll + t5 = W2 (fromIntegral t4) t3 + t6 = W2 r1 hll + (t8, t7) = addWithCarry t6 v + (t10, t9) = addWithCarry t7 v + loWord (W2 _ l) = l + (q2, r2) = + if t5 > t6 + then if loWord t8 == 0 + then if t7 >= t5 + then (q1 - 1, t7 - t5) + else if loWord t10 == 0 + then (q1 - 2, t9 - t5) + else (q1 - 2, (maxBound - t5) + t9 + 1) + else (q1 - 1, (maxBound - t5) + t7 + 1) + else (q1, t6 - t5) + where + div1 :: a -> b -> b -> (BigWord a b, b) + div1 hhh hll by = go hhh hll 0 + where + (t2, t1) = quotRem maxBound by + go h l c + | z == 0 = (c + W2 (fromIntegral t8) t7 + W2 0 t10, t9) + | otherwise = go (fromIntegral z) t5 (c + (W2 (fromIntegral t8) t7)) + where + h1 = fromIntegral h + (t4, t3) = mulWithCarry h1 (t1 + 1) + (t6, t5) = addWithCarry t3 l + z = t4 + t6 + (t8, t7) = mulWithCarry h1 t2 + (t10, t9) = quotRem t5 by + + div2 :: a -> a -> a -> ((a,a), a) + div2 hhh hll by = go hhh hll (0, 0) + where + (t2, t1) = quotRem maxBound by + go h l c + | z == 0 = (addT (addT c (t8, t7)) (0, t10), t9) + | otherwise = go z t5 (addT c (t8, t7)) + where + (t4, t3) = mulWithCarry h (t1 + 1) + (t6, t5) = addWithCarry t3 l + z = t4 + t6 + (t8, t7) = mulWithCarry h t2 + (t10, t9) = quotRem t5 by + + addT (lhh, lhl) (llh, lll) = + let (t4', t3') = addWithCarry lhl lll + in (lhh + llh + t4', t3') + + +instance ( Integral a, FiniteBits a, Num2 a + , Integral b, FiniteBits b, Num2 b + , BigWordCtx a b + ) + => Num2 (BigWord a b) where + type Signed (BigWord a b) = BigInt (Signed a) b + type Unsigned (BigWord a b) = BigWord (Unsigned a) b + -- + signed (W2 hi lo) = I2 (signed hi) lo + unsigned = id + -- + addWithCarry (W2 xh xl) (W2 yh yl) = (W2 0 w, W2 v u) + where + (t1, u) = addWithCarry xl yl + (t3, t2) = addWithCarry xh (fromIntegral t1) + (t4, v) = addWithCarry t2 yh + w = fromIntegral (t3 + t4) + + mulWithCarry (W2 xh xl) (W2 yh yl) = + ( W2 (hhh + fromIntegral (shiftR t9 y) + shiftL x z) (shiftL t9 z .|. shiftR t3 y) + , W2 (fromIntegral t3) lll) + where + (llh, lll) = mulWithCarry xl yl + (hlh, hll) = mulWithCarry (fromIntegral xh) yl + (lhh, lhl) = mulWithCarry xl (fromIntegral yh) + (hhh, hhl) = mulWithCarry xh yh + (t2, t1) = addWithCarry llh hll + (t4, t3) = addWithCarry t1 lhl + (t6, t5) = addWithCarry (fromIntegral hhl) (t2 + t4) + (t8, t7) = addWithCarry t5 lhh + (t10, t9) = addWithCarry t7 hlh + x = fromIntegral (t6 + t8 + t10) + y = finiteBitSize (undefined::a) + z = finiteBitSize (undefined::b) - y + + +instance ( Integral a, FiniteBits a + , Integral b, FiniteBits b + , BigWordCtx a b + ) + => Bits (BigWord a b) where + isSigned _ = False + bitSize = finiteBitSize + bitSizeMaybe = Just . finiteBitSize + + W2 xh xl .&. W2 yh yl = W2 (xh .&. yh) (xl .&. yl) + W2 xh xl .|. W2 yh yl = W2 (xh .|. yh) (xl .|. yl) + W2 xh xl `xor` W2 yh yl = W2 (xh `xor` yh) (xl `xor` yl) + complement (W2 hi lo) = W2 (complement hi) (complement lo) + + shiftL (W2 hi lo) x + | y > 0 = W2 (shiftL hi x .|. fromIntegral (shiftR lo y)) (shiftL lo x) + | otherwise = W2 (fromIntegral (shiftL lo (negate y))) 0 + where + y = finiteBitSize (undefined::b) - x + + shiftR (W2 hi lo) x = W2 hi' lo' + where + hi' = shiftR hi x + lo' | y >= 0 = shiftL (fromIntegral hi) y .|. shiftR lo x + | otherwise = z + + y = finiteBitSize (undefined::b) - x + z = shiftR (fromIntegral hi) (negate y) + + rotateL (W2 hi lo) x + | y >= 0 = W2 (fromIntegral (shiftL lo y) .|. shiftR hi z) + (shiftL (fromIntegral hi) (finiteBitSize (undefined::b) - z) .|. shiftR lo z) + | otherwise = W2 (fromIntegral (shiftR lo (negate y)) .|. shiftL hi x) + (shift (fromIntegral hi) (finiteBitSize (undefined::b) - z) .|. shiftL lo x .|. shiftR lo z) + where + y = x - finiteBitSize (undefined::b) + z = finiteBitSize (undefined::BigWord a b) - x + + rotateR x y = rotateL x (finiteBitSize (undefined::BigWord a b) - y) + + bit n + | m >= 0 = W2 (bit m) 0 + | otherwise = W2 0 (bit n) + where + m = n - finiteBitSize (undefined::b) + + testBit (W2 hi lo) n + | m >= 0 = testBit hi m + | otherwise = testBit lo n + where + m = n - finiteBitSize (undefined::b) + + setBit (W2 hi lo) n + | m >= 0 = W2 (setBit hi m) lo + | otherwise = W2 hi (setBit lo n) + where + m = n - finiteBitSize (undefined::b) + + clearBit (W2 hi lo) n + | m >= 0 = W2 (clearBit hi m) lo + | otherwise = W2 hi (clearBit lo n) + where + m = n - finiteBitSize (undefined::b) + + complementBit (W2 hi lo) n + | m >= 0 = W2 (complementBit hi m) lo + | otherwise = W2 hi (complementBit lo n) + where + m = n - finiteBitSize (undefined::b) + + popCount (W2 hi lo) = popCount hi + popCount lo + + +instance ( Integral a, FiniteBits a + , Integral b, FiniteBits b + , BigWordCtx a b + ) + => FiniteBits (BigWord a b) where + finiteBitSize _ = finiteBitSize (undefined::a) + + finiteBitSize (undefined::b) + + countLeadingZeros (W2 hi lo) + | x == wsib = wsib + countLeadingZeros lo + | otherwise = x + where + x = countLeadingZeros hi + wsib = finiteBitSize (undefined::a) + + countTrailingZeros (W2 hi lo) + | x == wsib = wsib + countTrailingZeros hi + | otherwise = x + where + x = countTrailingZeros lo + wsib = finiteBitSize (undefined::b) + diff --git a/src/Data/Array/Accelerate/Internal/LLVM/Native.hs b/src/Data/Array/Accelerate/Internal/LLVM/Native.hs new file mode 100644 --- /dev/null +++ b/src/Data/Array/Accelerate/Internal/LLVM/Native.hs @@ -0,0 +1,238 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE MagicHash #-} +-- | +-- Module : Data.Array.Accelerate.Internal.LLVM.Native +-- Copyright : [2016] Trevor L. McDonell +-- License : BSD3 +-- +-- Maintainer : Trevor L. McDonell +-- Stability : experimental +-- Portability : non-portable (GHC extensions) +-- + +module Data.Array.Accelerate.Internal.LLVM.Native ( + + -- Operators from Num2 + addWithCarryInt64#, mulWithCarryInt64#, + addWithCarryWord64#, mulWithCarryWord64#, + + -- Operators from Num + addInt128#, subInt128#, mulInt128#, + addWord128#, subWord128#, mulWord128#, + + -- Operators from Integral + quotInt128#, remInt128#, quotRemInt128#, + quotWord128#, remWord128#, quotRemWord128#, + +) where + +import Data.Array.Accelerate as A +import Data.Array.Accelerate.Internal.BigInt +import Data.Array.Accelerate.Internal.BigWord +import Data.Array.Accelerate.Internal.Orphans.Elt () + +#ifdef ACCELERATE_LLVM_NATIVE_BACKEND +import Data.Array.Accelerate.LLVM.CodeGen.Sugar +import Data.Array.Accelerate.LLVM.Native.Foreign as A +import qualified Data.Array.Accelerate.Internal.LLVM.Prim as Prim +#endif + + +#ifdef ACCELERATE_LLVM_NATIVE_BACKEND +wrap2 :: (Elt a, Elt b, Elt c) + => String -- name of the operation + -> IRFun1 Native () ((a, b) -> c) -- foreign implementation + -> (Exp a -> Exp b -> Exp c) -- fallback implementation + -> Exp a + -> Exp b + -> Exp c +wrap2 str f g = A.curry (foreignExp (ForeignExp str f) (A.uncurry g)) +#endif + +-- Operations from Num2 +-- -------------------- + +addWithCarryInt64# + :: (Exp Int64 -> Exp Int64 -> Exp (Int64, Word64)) + -> Exp Int64 + -> Exp Int64 + -> Exp (Int64, Word64) +#ifdef ACCELERATE_LLVM_NATIVE_BACKEND +addWithCarryInt64# = wrap2 "addWithCarryInt64#" Prim.addWithCarryInt64# +#else +addWithCarryInt64# = id +#endif + +mulWithCarryInt64# + :: (Exp Int64 -> Exp Int64 -> Exp (Int64, Word64)) + -> Exp Int64 + -> Exp Int64 + -> Exp (Int64, Word64) +#ifdef ACCELERATE_LLVM_NATIVE_BACKEND +mulWithCarryInt64# = wrap2 "mulWithCarryInt64#" Prim.mulWithCarryInt64# +#else +mulWithCarryInt64# = id +#endif + +addWithCarryWord64# + :: (Exp Word64 -> Exp Word64 -> Exp (Word64, Word64)) + -> Exp Word64 + -> Exp Word64 + -> Exp (Word64, Word64) +#ifdef ACCELERATE_LLVM_NATIVE_BACKEND +addWithCarryWord64# = wrap2 "addWithCarryWord64#" Prim.addWithCarryWord64# +#else +addWithCarryWord64# = id +#endif + +mulWithCarryWord64# + :: (Exp Word64 -> Exp Word64 -> Exp (Word64, Word64)) + -> Exp Word64 + -> Exp Word64 + -> Exp (Word64, Word64) +#ifdef ACCELERATE_LLVM_NATIVE_BACKEND +mulWithCarryWord64# = wrap2 "mulWithCarryWord64#" Prim.mulWithCarryWord64# +#else +mulWithCarryWord64# = id +#endif + + +-- Operations from Num +-- ------------------- + +addInt128# + :: (Exp Int128 -> Exp Int128 -> Exp Int128) + -> Exp Int128 + -> Exp Int128 + -> Exp Int128 +#ifdef ACCELERATE_LLVM_NATIVE_BACKEND +addInt128# = wrap2 "addInt128#" Prim.addInt128# +#else +addInt128# = id +#endif + +subInt128# + :: (Exp Int128 -> Exp Int128 -> Exp Int128) + -> Exp Int128 + -> Exp Int128 + -> Exp Int128 +#ifdef ACCELERATE_LLVM_NATIVE_BACKEND +subInt128# = wrap2 "subInt128#" Prim.subInt128# +#else +subInt128# = id +#endif + +mulInt128# + :: (Exp Int128 -> Exp Int128 -> Exp Int128) + -> Exp Int128 + -> Exp Int128 + -> Exp Int128 +#ifdef ACCELERATE_LLVM_NATIVE_BACKEND +mulInt128# = wrap2 "mulInt128#" Prim.mulInt128# +#else +mulInt128# = id +#endif + +addWord128# + :: (Exp Word128 -> Exp Word128 -> Exp Word128) + -> Exp Word128 + -> Exp Word128 + -> Exp Word128 +#ifdef ACCELERATE_LLVM_NATIVE_BACKEND +addWord128# = wrap2 "addWord128#" Prim.addWord128# +#else +addWord128# = id +#endif + +subWord128# + :: (Exp Word128 -> Exp Word128 -> Exp Word128) + -> Exp Word128 + -> Exp Word128 + -> Exp Word128 +#ifdef ACCELERATE_LLVM_NATIVE_BACKEND +subWord128# = wrap2 "subWord128#" Prim.subWord128# +#else +subWord128# = id +#endif + +mulWord128# + :: (Exp Word128 -> Exp Word128 -> Exp Word128) + -> Exp Word128 + -> Exp Word128 + -> Exp Word128 +#ifdef ACCELERATE_LLVM_NATIVE_BACKEND +mulWord128# = wrap2 "mulWord128#" Prim.mulWord128# +#else +mulWord128# = id +#endif + + +-- Operations from Integral +-- ------------------------ + +quotInt128# + :: (Exp Int128 -> Exp Int128 -> Exp Int128) + -> Exp Int128 + -> Exp Int128 + -> Exp Int128 +#ifdef ACCELERATE_LLVM_NATIVE_BACKEND +quotInt128# = wrap2 "quotInt128#" Prim.quotInt128# +#else +quotInt128# = id +#endif + +remInt128# + :: (Exp Int128 -> Exp Int128 -> Exp Int128) + -> Exp Int128 + -> Exp Int128 + -> Exp Int128 +#ifdef ACCELERATE_LLVM_NATIVE_BACKEND +remInt128# = wrap2 "remInt128#" Prim.remInt128# +#else +remInt128# = id +#endif + +quotRemInt128# + :: (Exp Int128 -> Exp Int128 -> Exp (Int128, Int128)) + -> Exp Int128 + -> Exp Int128 + -> Exp (Int128, Int128) +#ifdef ACCELERATE_LLVM_NATIVE_BACKEND +quotRemInt128# = wrap2 "quotRemInt128#" Prim.quotRemInt128# +#else +quotRemInt128# = id +#endif + +quotWord128# + :: (Exp Word128 -> Exp Word128 -> Exp Word128) + -> Exp Word128 + -> Exp Word128 + -> Exp Word128 +#ifdef ACCELERATE_LLVM_NATIVE_BACKEND +quotWord128# = wrap2 "quotWord128#" Prim.quotWord128# +#else +quotWord128# = id +#endif + +remWord128# + :: (Exp Word128 -> Exp Word128 -> Exp Word128) + -> Exp Word128 + -> Exp Word128 + -> Exp Word128 +#ifdef ACCELERATE_LLVM_NATIVE_BACKEND +remWord128# = wrap2 "remWord128#" Prim.remWord128# +#else +remWord128# = id +#endif + +quotRemWord128# + :: (Exp Word128 -> Exp Word128 -> Exp (Word128, Word128)) + -> Exp Word128 + -> Exp Word128 + -> Exp (Word128, Word128) +#ifdef ACCELERATE_LLVM_NATIVE_BACKEND +quotRemWord128# = wrap2 "quotRemWord128#" Prim.quotRemWord128# +#else +quotRemWord128# = id +#endif + diff --git a/src/Data/Array/Accelerate/Internal/LLVM/PTX.hs b/src/Data/Array/Accelerate/Internal/LLVM/PTX.hs new file mode 100644 --- /dev/null +++ b/src/Data/Array/Accelerate/Internal/LLVM/PTX.hs @@ -0,0 +1,238 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE MagicHash #-} +-- | +-- Module : Data.Array.Accelerate.Internal.LLVM.PTX +-- Copyright : [2016] Trevor L. McDonell +-- License : BSD3 +-- +-- Maintainer : Trevor L. McDonell +-- Stability : experimental +-- Portability : non-portable (GHC extensions) +-- + +module Data.Array.Accelerate.Internal.LLVM.PTX ( + + -- Operators from Num2 + addWithCarryInt64#, mulWithCarryInt64#, + addWithCarryWord64#, mulWithCarryWord64#, + + -- Operators from Num + addInt128#, subInt128#, mulInt128#, + addWord128#, subWord128#, mulWord128#, + + -- Operators from Integral + quotInt128#, remInt128#, quotRemInt128#, + quotWord128#, remWord128#, quotRemWord128#, + +) where + +import Data.Array.Accelerate as A +import Data.Array.Accelerate.Internal.BigInt +import Data.Array.Accelerate.Internal.BigWord +import Data.Array.Accelerate.Internal.Orphans.Elt () + +#ifdef ACCELERATE_LLVM_PTX_BACKEND +import Data.Array.Accelerate.LLVM.CodeGen.Sugar +import Data.Array.Accelerate.LLVM.PTX.Foreign as A +import qualified Data.Array.Accelerate.Internal.LLVM.Prim as Prim +#endif + + +#ifdef ACCELERATE_LLVM_PTX_BACKEND +wrap2 :: (Elt a, Elt b, Elt c) + => String -- name of the operation + -> IRFun1 PTX () ((a, b) -> c) -- foreign implementation + -> (Exp a -> Exp b -> Exp c) -- fallback implementation + -> Exp a + -> Exp b + -> Exp c +wrap2 str f g = A.curry (foreignExp (ForeignExp str f) (A.uncurry g)) +#endif + +-- Operations from Num2 +-- -------------------- + +addWithCarryInt64# + :: (Exp Int64 -> Exp Int64 -> Exp (Int64, Word64)) + -> Exp Int64 + -> Exp Int64 + -> Exp (Int64, Word64) +#ifdef ACCELERATE_LLVM_PTX_BACKEND +addWithCarryInt64# = wrap2 "addWithCarryInt64#" Prim.addWithCarryInt64# +#else +addWithCarryInt64# = id +#endif + +mulWithCarryInt64# + :: (Exp Int64 -> Exp Int64 -> Exp (Int64, Word64)) + -> Exp Int64 + -> Exp Int64 + -> Exp (Int64, Word64) +#ifdef ACCELERATE_LLVM_PTX_BACKEND +mulWithCarryInt64# = wrap2 "mulWithCarryInt64#" Prim.mulWithCarryInt64# +#else +mulWithCarryInt64# = id +#endif + +addWithCarryWord64# + :: (Exp Word64 -> Exp Word64 -> Exp (Word64, Word64)) + -> Exp Word64 + -> Exp Word64 + -> Exp (Word64, Word64) +#ifdef ACCELERATE_LLVM_PTX_BACKEND +addWithCarryWord64# = wrap2 "addWithCarryWord64#" Prim.addWithCarryWord64# +#else +addWithCarryWord64# = id +#endif + +mulWithCarryWord64# + :: (Exp Word64 -> Exp Word64 -> Exp (Word64, Word64)) + -> Exp Word64 + -> Exp Word64 + -> Exp (Word64, Word64) +#ifdef ACCELERATE_LLVM_PTX_BACKEND +mulWithCarryWord64# = wrap2 "mulWithCarryWord64#" Prim.mulWithCarryWord64# +#else +mulWithCarryWord64# = id +#endif + + +-- Operations from Num +-- ------------------- + +addInt128# + :: (Exp Int128 -> Exp Int128 -> Exp Int128) + -> Exp Int128 + -> Exp Int128 + -> Exp Int128 +#ifdef ACCELERATE_LLVM_PTX_BACKEND +addInt128# = wrap2 "addInt128#" Prim.addInt128# +#else +addInt128# = id +#endif + +subInt128# + :: (Exp Int128 -> Exp Int128 -> Exp Int128) + -> Exp Int128 + -> Exp Int128 + -> Exp Int128 +#ifdef ACCELERATE_LLVM_PTX_BACKEND +subInt128# = wrap2 "subInt128#" Prim.subInt128# +#else +subInt128# = id +#endif + +mulInt128# + :: (Exp Int128 -> Exp Int128 -> Exp Int128) + -> Exp Int128 + -> Exp Int128 + -> Exp Int128 +#ifdef ACCELERATE_LLVM_PTX_BACKEND +mulInt128# = wrap2 "mulInt128#" Prim.mulInt128# +#else +mulInt128# = id +#endif + +addWord128# + :: (Exp Word128 -> Exp Word128 -> Exp Word128) + -> Exp Word128 + -> Exp Word128 + -> Exp Word128 +#ifdef ACCELERATE_LLVM_PTX_BACKEND +addWord128# = wrap2 "addWord128#" Prim.addWord128# +#else +addWord128# = id +#endif + +subWord128# + :: (Exp Word128 -> Exp Word128 -> Exp Word128) + -> Exp Word128 + -> Exp Word128 + -> Exp Word128 +#ifdef ACCELERATE_LLVM_PTX_BACKEND +subWord128# = wrap2 "subWord128#" Prim.subWord128# +#else +subWord128# = id +#endif + +mulWord128# + :: (Exp Word128 -> Exp Word128 -> Exp Word128) + -> Exp Word128 + -> Exp Word128 + -> Exp Word128 +#ifdef ACCELERATE_LLVM_PTX_BACKEND +mulWord128# = wrap2 "mulWord128#" Prim.mulWord128# +#else +mulWord128# = id +#endif + + +-- Operations from Integral +-- ------------------------ + +quotInt128# + :: (Exp Int128 -> Exp Int128 -> Exp Int128) + -> Exp Int128 + -> Exp Int128 + -> Exp Int128 +#ifdef ACCELERATE_LLVM_PTX_BACKEND +quotInt128# = wrap2 "quotInt128#" Prim.quotInt128# +#else +quotInt128# = id +#endif + +remInt128# + :: (Exp Int128 -> Exp Int128 -> Exp Int128) + -> Exp Int128 + -> Exp Int128 + -> Exp Int128 +#ifdef ACCELERATE_LLVM_PTX_BACKEND +remInt128# = wrap2 "remInt128#" Prim.remInt128# +#else +remInt128# = id +#endif + +quotRemInt128# + :: (Exp Int128 -> Exp Int128 -> Exp (Int128, Int128)) + -> Exp Int128 + -> Exp Int128 + -> Exp (Int128, Int128) +#ifdef ACCELERATE_LLVM_PTX_BACKEND +quotRemInt128# = wrap2 "quotRemInt128#" Prim.quotRemInt128# +#else +quotRemInt128# = id +#endif + +quotWord128# + :: (Exp Word128 -> Exp Word128 -> Exp Word128) + -> Exp Word128 + -> Exp Word128 + -> Exp Word128 +#ifdef ACCELERATE_LLVM_PTX_BACKEND +quotWord128# = wrap2 "quotWord128#" Prim.quotWord128# +#else +quotWord128# = id +#endif + +remWord128# + :: (Exp Word128 -> Exp Word128 -> Exp Word128) + -> Exp Word128 + -> Exp Word128 + -> Exp Word128 +#ifdef ACCELERATE_LLVM_PTX_BACKEND +remWord128# = wrap2 "remWord128#" Prim.remWord128# +#else +remWord128# = id +#endif + +quotRemWord128# + :: (Exp Word128 -> Exp Word128 -> Exp (Word128, Word128)) + -> Exp Word128 + -> Exp Word128 + -> Exp (Word128, Word128) +#ifdef ACCELERATE_LLVM_PTX_BACKEND +quotRemWord128# = wrap2 "quotRemWord128#" Prim.quotRemWord128# +#else +quotRemWord128# = id +#endif + diff --git a/src/Data/Array/Accelerate/Internal/LLVM/Prim.hs b/src/Data/Array/Accelerate/Internal/LLVM/Prim.hs new file mode 100644 --- /dev/null +++ b/src/Data/Array/Accelerate/Internal/LLVM/Prim.hs @@ -0,0 +1,256 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE MagicHash #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TypeFamilies #-} +-- | +-- Module : Data.Array.Accelerate.Internal.LLVM.Prim +-- Copyright : [2016] Trevor L. McDonell +-- License : BSD3 +-- +-- Maintainer : Trevor L. McDonell +-- Stability : experimental +-- Portability : non-portable (GHC extensions) +-- +-- Primops for LLVM backends +-- + +module Data.Array.Accelerate.Internal.LLVM.Prim ( + + -- Operators from Num2 + addWithCarryInt64#, mulWithCarryInt64#, + addWithCarryWord64#, mulWithCarryWord64#, + + -- Operators from Num + addInt128#, subInt128#, mulInt128#, + addWord128#, subWord128#, mulWord128#, + + -- Operators from Integral + quotInt128#, remInt128#, quotRemInt128#, + quotWord128#, remWord128#, quotRemWord128#, + +) where + +import Data.Int +import Data.Word + +import Data.Array.Accelerate.Error + +import Data.Array.Accelerate.Internal.BigInt +import Data.Array.Accelerate.Internal.BigWord +import Data.Array.Accelerate.Internal.Orphans.Elt () + +import Data.Array.Accelerate.LLVM.CodeGen.Downcast +import Data.Array.Accelerate.LLVM.CodeGen.IR ( IR(..), Operands(..) ) +import Data.Array.Accelerate.LLVM.CodeGen.Monad ( CodeGen, freshName, instr_ ) +import Data.Array.Accelerate.LLVM.CodeGen.Sugar +import qualified Data.Array.Accelerate.LLVM.CodeGen.Arithmetic as A +import qualified LLVM.AST.Type.Name as A +import qualified LLVM.AST.Type.Operand as A +import qualified LLVM.AST.Type.Representation as A + +import LLVM.AST.Constant ( Constant(Int) ) +import LLVM.AST.Instruction hiding ( nsw, nuw ) +import LLVM.AST.Name +import LLVM.AST.Operand +import LLVM.AST.Type + + +-- Primitive instruction wrappers +-- ------------------------------ + +-- Operations from Num2 +-- -------------------- + +addWithCarryInt64# :: IRFun1 arch () ((Int64, Int64) -> (Int64, Word64)) +addWithCarryInt64# = IRFun1 $ A.uncurry (prim_wideningInt64 (Add nsw nuw)) + +mulWithCarryInt64# :: IRFun1 arch () ((Int64, Int64) -> (Int64, Word64)) +mulWithCarryInt64# = IRFun1 $ A.uncurry (prim_wideningInt64 (Mul nsw nuw)) + +addWithCarryWord64# :: IRFun1 arch () ((Word64, Word64) -> (Word64, Word64)) +addWithCarryWord64# = IRFun1 $ A.uncurry (prim_wideningWord64 (Add nsw nuw)) + +mulWithCarryWord64# :: IRFun1 arch () ((Word64, Word64) -> (Word64, Word64)) +mulWithCarryWord64# = IRFun1 $ A.uncurry (prim_wideningWord64 (Mul nsw nuw)) + + +prim_wideningInt64 :: (Operand -> Operand -> InstructionMetadata -> Instruction) -> IR Int64 -> IR Int64 -> CodeGen (IR (Int64, Word64)) +prim_wideningInt64 op (IR (OP_Int64 x)) (IR (OP_Int64 y)) = do + a <- instr i128 (SExt (downcast x) i128 md) + b <- instr i128 (SExt (downcast y) i128 md) + c <- instr i128 (op a b md) + (d,e) <- unpackInt128 c + return $ A.pair (IR (upcastInt64 d)) (IR (upcastWord64 e)) + +prim_wideningWord64 :: (Operand -> Operand -> InstructionMetadata -> Instruction) -> IR Word64 -> IR Word64 -> CodeGen (IR (Word64, Word64)) +prim_wideningWord64 op (IR (OP_Word64 x)) (IR (OP_Word64 y)) = do + a <- instr i128 (ZExt (downcast x) i128 md) + b <- instr i128 (ZExt (downcast y) i128 md) + c <- instr i128 (op a b md) + (d,e) <- unpackWord128 c + return $ A.pair (IR (upcastWord64 d)) (IR (upcastWord64 e)) + + +-- Operations from Num +-- ------------------- + +addInt128# :: IRFun1 arch () ((Int128, Int128) -> Int128) +addInt128# = IRFun1 $ A.uncurry (prim_binaryInt128 (Add nsw nuw)) + +subInt128# :: IRFun1 arch () ((Int128, Int128) -> Int128) +subInt128# = IRFun1 $ A.uncurry (prim_binaryInt128 (Sub nsw nuw)) + +mulInt128# :: IRFun1 arch () ((Int128, Int128) -> Int128) +mulInt128# = IRFun1 $ A.uncurry (prim_binaryInt128 (Mul nsw nuw)) + +addWord128# :: IRFun1 arch () ((Word128, Word128) -> Word128) +addWord128# = IRFun1 $ A.uncurry (prim_binaryWord128 (Add nsw nuw)) + +subWord128# :: IRFun1 arch () ((Word128, Word128) -> Word128) +subWord128# = IRFun1 $ A.uncurry (prim_binaryWord128 (Sub nsw nuw)) + +mulWord128# :: IRFun1 arch () ((Word128, Word128) -> Word128) +mulWord128# = IRFun1 $ A.uncurry (prim_binaryWord128 (Mul nsw nuw)) + + +-- Operations from Integral +-- ------------------------ + +quotInt128# :: IRFun1 arch () ((Int128, Int128) -> Int128) +quotInt128# = IRFun1 $ A.uncurry (prim_binaryInt128 (SDiv False)) + +remInt128# :: IRFun1 arch () ((Int128, Int128) -> Int128) +remInt128# = IRFun1 $ A.uncurry (prim_binaryInt128 SRem) + +quotRemInt128# :: IRFun1 arch () ((Int128, Int128) -> (Int128,Int128)) +quotRemInt128# = IRFun1 $ A.uncurry quotRem' + where + quotRem' :: IR Int128 -> IR Int128 -> CodeGen (IR (Int128, Int128)) + quotRem' (IR xx) (IR yy) + | OP_Pair (OP_Pair OP_Unit (OP_Int64 xh)) (OP_Word64 xl) <- xx + , OP_Pair (OP_Pair OP_Unit (OP_Int64 yh)) (OP_Word64 yl) <- yy + = do + x <- packWord128 (downcast xh) (downcast xl) + y <- packWord128 (downcast yh) (downcast yl) + q <- instr i128 (SDiv False x y md) + z <- instr i128 (Mul nsw nuw y q md) + r <- instr i128 (Sub nsw nuw x z md) + (qh,ql) <- unpackInt128 q + (rh,rl) <- unpackInt128 r + return $ A.pair (upcastInt128 qh ql) (upcastInt128 rh rl) + + +quotWord128# :: IRFun1 arch () ((Word128, Word128) -> Word128) +quotWord128# = IRFun1 $ A.uncurry (prim_binaryWord128 (UDiv False)) + +remWord128# :: IRFun1 arch () ((Word128, Word128) -> Word128) +remWord128# = IRFun1 $ A.uncurry (prim_binaryWord128 URem) + +quotRemWord128# :: IRFun1 arch () ((Word128, Word128) -> (Word128,Word128)) +quotRemWord128# = IRFun1 $ A.uncurry quotRem' + where + quotRem' :: IR Word128 -> IR Word128 -> CodeGen (IR (Word128, Word128)) + quotRem' (IR xx) (IR yy) + | OP_Pair (OP_Pair OP_Unit (OP_Word64 xh)) (OP_Word64 xl) <- xx + , OP_Pair (OP_Pair OP_Unit (OP_Word64 yh)) (OP_Word64 yl) <- yy + = do + x <- packWord128 (downcast xh) (downcast xl) + y <- packWord128 (downcast yh) (downcast yl) + q <- instr i128 (UDiv False x y md) + z <- instr i128 (Mul nsw nuw y q md) + r <- instr i128 (Sub nsw nuw x z md) + (qh,ql) <- unpackWord128 q + (rh,rl) <- unpackWord128 r + return $ A.pair (upcastWord128 qh ql) (upcastWord128 rh rl) + + +-- Helpers + +prim_binaryWord128 :: (Operand -> Operand -> InstructionMetadata -> Instruction) -> IR Word128 -> IR Word128 -> CodeGen (IR Word128) +prim_binaryWord128 op xx yy + | IR (OP_Pair (OP_Pair OP_Unit (OP_Word64 xh)) (OP_Word64 xl)) <- xx + , IR (OP_Pair (OP_Pair OP_Unit (OP_Word64 yh)) (OP_Word64 yl)) <- yy + = do + x' <- packWord128 (downcast xh) (downcast xl) + y' <- packWord128 (downcast yh) (downcast yl) + r <- instr i128 (op x' y' md) + (hi,lo) <- unpackWord128 r + return $ upcastWord128 hi lo + +prim_binaryInt128 :: (Operand -> Operand -> InstructionMetadata -> Instruction) -> IR Int128 -> IR Int128 -> CodeGen (IR Int128) +prim_binaryInt128 op xx yy + | IR (OP_Pair (OP_Pair OP_Unit (OP_Int64 xh)) (OP_Word64 xl)) <- xx + , IR (OP_Pair (OP_Pair OP_Unit (OP_Int64 yh)) (OP_Word64 yl)) <- yy + = do + x' <- packInt128 (downcast xh) (downcast xl) + y' <- packInt128 (downcast yh) (downcast yl) + r <- instr i128 (op x' y' md) + (hi,lo) <- unpackInt128 r + return $ upcastInt128 hi lo + + +-- Prim +-- ---- + +nsw :: Bool +nsw = False + +nuw :: Bool +nuw = False + +md :: InstructionMetadata +md = [] + +fresh :: CodeGen Name +fresh = downcast <$> freshName + +instr :: Type -> Instruction -> CodeGen Operand +instr ty ins = do + name <- fresh + instr_ (name := ins) + return (LocalReference ty name) + +packInt128 :: Operand -> Operand -> CodeGen Operand +packInt128 hi lo = do + a <- instr i128 (SExt hi i128 md) + b <- instr i128 (Shl nsw nuw a (ConstantOperand (Int 128 64)) md) + c <- instr i128 (ZExt lo i128 md) + d <- instr i128 (Or b c md) + return d + +packWord128 :: Operand -> Operand -> CodeGen Operand +packWord128 hi lo = do + a <- instr i128 (ZExt hi i128 md) + b <- instr i128 (Shl nsw nuw a (ConstantOperand (Int 128 64)) md) + c <- instr i128 (ZExt lo i128 md) + d <- instr i128 (Or b c md) + return d + +unpackInt128 :: Operand -> CodeGen (Operand,Operand) +unpackInt128 x = do + a <- instr i128 (AShr False x (ConstantOperand (Int 128 64)) md) + b <- instr i64 (Trunc a i64 md) + c <- instr i64 (Trunc x i64 md) + return (b,c) + +unpackWord128 :: Operand -> CodeGen (Operand,Operand) +unpackWord128 x = do + a <- instr i128 (LShr False x (ConstantOperand (Int 128 64)) md) + b <- instr i64 (Trunc a i64 md) + c <- instr i64 (Trunc x i64 md) + return (b,c) + +upcastInt64 :: Operand -> Operands Int64 +upcastInt64 (LocalReference (IntegerType 64) (UnName x)) = OP_Int64 (A.LocalReference A.type' (A.UnName x)) +upcastInt64 _ = $internalError "upcastInt64" "expected local reference" + +upcastWord64 :: Operand -> Operands Word64 +upcastWord64 (LocalReference (IntegerType 64) (UnName x)) = OP_Word64 (A.LocalReference A.type' (A.UnName x)) +upcastWord64 _ = $internalError "upcastWord64" "expected local reference" + +upcastInt128 :: Operand -> Operand -> IR Int128 +upcastInt128 hi lo = IR $ OP_Pair (OP_Pair OP_Unit (upcastInt64 hi)) (upcastWord64 lo) + +upcastWord128 :: Operand -> Operand -> IR Word128 +upcastWord128 hi lo = IR $ OP_Pair (OP_Pair OP_Unit (upcastWord64 hi)) (upcastWord64 lo) + diff --git a/src/Data/Array/Accelerate/Internal/Num2.hs b/src/Data/Array/Accelerate/Internal/Num2.hs new file mode 100644 --- /dev/null +++ b/src/Data/Array/Accelerate/Internal/Num2.hs @@ -0,0 +1,177 @@ +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE CPP #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE MagicHash #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE UnboxedTuples #-} +-- | +-- Module : Data.Array.Accelerate.Internal.Num2 +-- Copyright : [2016] Trevor L. McDonell +-- License : BSD3 +-- +-- Maintainer : Trevor L. McDonell +-- Stability : experimental +-- Portability : non-portable (GHC extensions) +-- + +#include "MachDeps.h" + +module Data.Array.Accelerate.Internal.Num2 ( Num2(..) ) + where + +import Data.Bits +import Data.Int +import Data.Word +import Prelude + +#if UNBOXED_TUPLES +import GHC.Prim ( plusWord2#, timesWord2# ) +#if WORD_SIZE_IN_BITS == 32 +import GHC.Word ( Word32(..) ) +#endif +#if WORD_SIZE_IN_BITS == 64 +import GHC.Word ( Word64(..) ) +#endif +#endif + + +-- | Addition and multiplication with carry +-- +class Num2 w where + type Signed w + type Unsigned w + -- + signed :: w -> Signed w + unsigned :: w -> Unsigned w + addWithCarry :: w -> w -> (w, Unsigned w) + mulWithCarry :: w -> w -> (w, Unsigned w) + + +-- Base +-- ---- + +instance Num2 Int8 where + type Signed Int8 = Int8 + type Unsigned Int8 = Word8 + -- + signed = id + unsigned = fromIntegral + addWithCarry = defaultUnwrapped ((+) :: Int16 -> Int16 -> Int16) + mulWithCarry = defaultUnwrapped ((*) :: Int16 -> Int16 -> Int16) + +instance Num2 Word8 where + type Signed Word8 = Int8 + type Unsigned Word8 = Word8 + -- + signed = fromIntegral + unsigned = id + addWithCarry = defaultUnwrapped ((+) :: Word16 -> Word16 -> Word16) + mulWithCarry = defaultUnwrapped ((*) :: Word16 -> Word16 -> Word16) + +instance Num2 Int16 where + type Signed Int16 = Int16 + type Unsigned Int16 = Word16 + -- + signed = id + unsigned = fromIntegral + addWithCarry = defaultUnwrapped ((+) :: Int32 -> Int32 -> Int32) + mulWithCarry = defaultUnwrapped ((*) :: Int32 -> Int32 -> Int32) + +instance Num2 Word16 where + type Signed Word16 = Int16 + type Unsigned Word16 = Word16 + -- + signed = fromIntegral + unsigned = id + addWithCarry = defaultUnwrapped ((+) :: Word32 -> Word32 -> Word32) + mulWithCarry = defaultUnwrapped ((*) :: Word32 -> Word32 -> Word32) + +instance Num2 Int32 where + type Signed Int32 = Int32 + type Unsigned Int32 = Word32 + -- + signed = id + unsigned = fromIntegral + addWithCarry = defaultUnwrapped ((+) :: Int64 -> Int64 -> Int64) + mulWithCarry = defaultUnwrapped ((*) :: Int64 -> Int64 -> Int64) + +instance Num2 Word32 where + type Signed Word32 = Int32 + type Unsigned Word32 = Word32 + -- + signed = fromIntegral + unsigned = id +#if UNBOXED_TUPLES && WORD_SIZE_IN_BITS == 32 + addWithCarry (W32# x#) (W32# y#) = case plusWord2# x# y# of (# hi#, lo# #) -> (W32# hi#, W32# lo#) + mulWithCarry (W32# x#) (W32# y#) = case timesWord2# x# y# of (# hi#, lo# #) -> (W32# hi#, W32# lo#) +#else + addWithCarry = defaultUnwrapped ((+) :: Word64 -> Word64 -> Word64) + mulWithCarry = defaultUnwrapped ((*) :: Word64 -> Word64 -> Word64) +#endif + +instance Num2 Int64 where + type Signed Int64 = Int64 + type Unsigned Int64 = Word64 + -- + signed = id + unsigned = fromIntegral + addWithCarry x y = hi `seq` lo `seq` (hi,lo) + where + extX = if x < 0 then maxBound else 0 + extY = if y < 0 then maxBound else 0 + (hi',lo) = unsigned x `addWithCarry` unsigned y + hi = signed (hi' + extX + extY) + + mulWithCarry x y = hi `seq` lo `seq` (hi,lo) + where + extX = if x < 0 then negate y else 0 + extY = if y < 0 then negate x else 0 + (hi',lo) = unsigned x `mulWithCarry` unsigned y + hi = signed hi' + extX + extY + +instance Num2 Word64 where + type Signed Word64 = Int64 + type Unsigned Word64 = Word64 + -- + signed = fromIntegral + unsigned = id +#if UNBOXED_TUPLES && WORD_SIZE_IN_BITS == 64 + addWithCarry (W64# x#) (W64# y#) = case plusWord2# x# y# of (# hi#, lo# #) -> (W64# hi#, W64# lo#) + mulWithCarry (W64# x#) (W64# y#) = case timesWord2# x# y# of (# hi#, lo# #) -> (W64# hi#, W64# lo#) +#else + addWithCarry x y = (hi,lo) + where + !lo = x + y + !hi | lo < x = 1 + | otherwise = 0 + -- + mulWithCarry x y = (hi,lo) + where + xHi = shiftR x 32 + yHi = shiftR y 32 + xLo = x .&. 0xFFFFFFFF + yLo = y .&. 0xFFFFFFFF + hi0 = xHi * yHi + lo0 = xLo * yLo + p1 = xHi * yLo + p2 = xLo * yHi + (uHi1, uLo) = addWithCarry (fromIntegral p1) (fromIntegral p2) + (uHi2, lo') = addWithCarry (fromIntegral (shiftR lo0 32)) uLo + !hi = hi0 + fromIntegral (uHi1::Word32) + fromIntegral uHi2 + shiftR p1 32 + shiftR p2 32 + !lo = shiftL (fromIntegral lo') 32 .|. (lo0 .&. 0xFFFFFFFF) +#endif + +{-# INLINE defaultUnwrapped #-} +defaultUnwrapped + :: (FiniteBits w, Bits ww, Integral w, Integral ww, Integral (Unsigned w)) + => (ww -> ww -> ww) + -> w + -> w + -> (w, Unsigned w) +defaultUnwrapped op x y = (hi, lo) + where + !r = fromIntegral x `op` fromIntegral y + !lo = fromIntegral r + !hi = fromIntegral (shiftR r (finiteBitSize x)) + diff --git a/src/Data/Array/Accelerate/Internal/Orphans.hs b/src/Data/Array/Accelerate/Internal/Orphans.hs new file mode 100644 --- /dev/null +++ b/src/Data/Array/Accelerate/Internal/Orphans.hs @@ -0,0 +1,16 @@ +-- | +-- Module : Data.Array.Accelerate.Internal.Orphans +-- Copyright : [2016] Trevor L. McDonell +-- License : BSD3 +-- +-- Maintainer : Trevor L. McDonell +-- Stability : experimental +-- Portability : non-portable (GHC extensions) +-- + +module Data.Array.Accelerate.Internal.Orphans () + where + +import Data.Array.Accelerate.Internal.Orphans.Elt () +import Data.Array.Accelerate.Internal.Orphans.Base () + diff --git a/src/Data/Array/Accelerate/Internal/Orphans/Base.hs b/src/Data/Array/Accelerate/Internal/Orphans/Base.hs new file mode 100644 --- /dev/null +++ b/src/Data/Array/Accelerate/Internal/Orphans/Base.hs @@ -0,0 +1,953 @@ +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MagicHash #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE QuasiQuotes #-} +{-# LANGUAGE RebindableSyntax #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE ViewPatterns #-} +{-# OPTIONS_GHC -fno-warn-orphans #-} +-- | +-- Module : Data.Array.Accelerate.Internal.Orphans.Base +-- Copyright : [2016] Trevor L. McDonell +-- License : BSD3 +-- +-- Maintainer : Trevor L. McDonell +-- Stability : experimental +-- Portability : non-portable (GHC extensions) +-- +-- Orphan instances for BigWord and BigInt for use with Accelerate. In +-- a separate module so that (a) we can use rebindable syntax; and (b) to avoid +-- excessive class constraints by placing instances next to each other. +-- + +module Data.Array.Accelerate.Internal.Orphans.Base () + where + +import Data.Array.Accelerate.Internal.BigInt +import Data.Array.Accelerate.Internal.BigWord +import Data.Array.Accelerate.Internal.Num2 +import Data.Array.Accelerate.Internal.Orphans.Elt () + +import qualified Data.Array.Accelerate.Internal.LLVM.Native as CPU +import qualified Data.Array.Accelerate.Internal.LLVM.PTX as PTX + +import Data.Array.Accelerate as A +import Data.Array.Accelerate.Array.Sugar as A ( eltType ) +import Data.Array.Accelerate.Analysis.Match as A +import Data.Array.Accelerate.Data.Bits as A +import Data.Array.Accelerate.Smart + +import Control.Monad +import Data.Maybe +import Data.Typeable +import Language.Haskell.TH hiding ( Exp ) +import Text.Printf +import Prelude ( id, fromInteger, otherwise ) +import qualified Prelude as P + + +-- BigWord +-- ------- + +type BigWordCtx hi lo = + ( Elt hi, Elt lo, Elt (BigWord hi lo) + , hi ~ Unsigned hi + , lo ~ Unsigned lo + , Exp hi ~ Unsigned (Exp hi) + , Exp lo ~ Unsigned (Exp lo) + ) + +mkW2 :: (Elt a, Elt b, Elt (BigWord a b)) => Exp a -> Exp b -> Exp (BigWord a b) +mkW2 a b = lift (W2 a b) + + +instance (Bounded a, Bounded b, Elt (BigWord a b)) => P.Bounded (Exp (BigWord a b)) where + minBound = mkW2 minBound minBound + maxBound = mkW2 maxBound maxBound + + +instance (Eq a, Eq b, Elt (BigWord a b)) => Eq (BigWord a b) where + (unlift -> W2 xh xl) == (unlift -> W2 yh yl) = xh == yh && xl == yl + (unlift -> W2 xh xl) /= (unlift -> W2 yh yl) = xh /= yh || xl /= yl + + +instance (Ord a, Ord b, Elt (BigWord a b)) => Ord (BigWord a b) where + (unlift -> W2 xh xl) < (unlift -> W2 yh yl) = xh == yh ? ( xl < yl, xh < yh ) + (unlift -> W2 xh xl) > (unlift -> W2 yh yl) = xh == yh ? ( xl > yl, xh > yh ) + (unlift -> W2 xh xl) <= (unlift -> W2 yh yl) = xh == yh ? ( xl <= yl, xh <= yh ) + (unlift -> W2 xh xl) >= (unlift -> W2 yh yl) = xh == yh ? ( xl >= yl, xh >= yh ) + + +instance ( Num a + , Integral b, Num2 (Exp b), FromIntegral b a + , Eq (BigWord a b) + , P.Num (BigWord a b) + , BigWordCtx a b + ) + => P.Num (Exp (BigWord a b)) where + negate (unlift -> W2 hi lo) = + if lo == 0 + then mkW2 (negate hi) 0 + else mkW2 (negate (hi+1)) (negate lo) + + abs = id + signum x = x == 0 ? (0,1) + fromInteger = constant . P.fromInteger + + {-# SPECIALIZE (+) :: Exp Word128 -> Exp Word128 -> Exp Word128 #-} + (+) | Just Refl <- matchWord128 (undefined::BigWord a b) = CPU.addWord128# $ PTX.addWord128# add + | otherwise = add + where + add :: Exp (BigWord a b) -> Exp (BigWord a b) -> Exp (BigWord a b) + add (unlift -> W2 xh xl) (unlift -> W2 yh yl) = mkW2 hi lo + where + lo = xl + yl + hi = xh + yh + if lo < xl then 1 else 0 + + {-# SPECIALIZE (-) :: Exp Word128 -> Exp Word128 -> Exp Word128 #-} + (-) | Just Refl <- matchWord128 (undefined::BigWord a b) = CPU.subWord128# $ PTX.subWord128# (\x y -> x + negate y) + | otherwise = \x y -> x + negate y + + {-# SPECIALIZE (*) :: Exp Word128 -> Exp Word128 -> Exp Word128 #-} + (*) | Just Refl <- matchWord128 (undefined::BigWord a b) = CPU.mulWord128# $ PTX.mulWord128# mul + | otherwise = mul + where + mul :: Exp (BigWord a b) -> Exp (BigWord a b) -> Exp (BigWord a b) + mul (unlift -> W2 xh xl) (unlift -> W2 yh yl) = mkW2 hi lo + where + hi = xh * fromIntegral yl + yh * fromIntegral xl + fromIntegral c + (c,lo) = mulWithCarry xl yl + + +instance ( Integral a, FiniteBits a, FromIntegral a b, Num2 (Exp a), Bounded a + , Integral b, FiniteBits b, FromIntegral b a, Num2 (Exp b), Bounded b + , Num (BigWord a b) + , Num2 (Exp (BigWord a b)) + , BigWordCtx a b + ) + => P.Integral (Exp (BigWord a b)) where + toInteger = error "Prelude.toInteger not supported for Accelerate types" + + {-# SPECIALIZE div :: Exp Word128 -> Exp Word128 -> Exp Word128 #-} + {-# SPECIALIZE mod :: Exp Word128 -> Exp Word128 -> Exp Word128 #-} + {-# SPECIALIZE divMod :: Exp Word128 -> Exp Word128 -> (Exp Word128, Exp Word128) #-} + div = quot + mod = rem + divMod = quotRem + + {-# SPECIALISE quot :: Exp Word128 -> Exp Word128 -> Exp Word128 #-} + quot | Just Refl <- matchWord128 (undefined::BigWord a b) = CPU.quotWord128# $ PTX.quotWord128# go + | otherwise = go + where + go x y = P.fst (quotRem x y) + + {-# SPECIALISE rem :: Exp Word128 -> Exp Word128 -> Exp Word128 #-} + rem | Just Refl <- matchWord128 (undefined::BigWord a b) = CPU.remWord128# $ PTX.remWord128# go + | otherwise = go + where + go x y = P.snd (quotRem x y) + + {-# SPECIALISE quotRem :: Exp Word128 -> Exp Word128 -> (Exp Word128, Exp Word128) #-} + quotRem | Just Refl <- matchWord128 (undefined::BigWord a b) = untup2 $$ CPU.quotRemWord128# $ PTX.quotRemWord128# quotRem' + | otherwise = untup2 $$ quotRem' + where + quotRem' :: Exp (BigWord a b) -> Exp (BigWord a b) -> Exp (BigWord a b, BigWord a b) + quotRem' x@(unlift -> W2 xh xl) y@(unlift -> W2 yh yl) + = xh < yh ? ( tup2 (0, x) + , xh == yh ? ( xl < yl ? ( tup2 (0, x) + , xl == yl ? ( tup2 (1, 0) + , {-xl > yl -} yh == 0 ? ( let (t2,t1) = quotRem xl yl + in lift (mkW2 0 t2, mkW2 0 t1) + , tup2 (1, mkW2 0 (xl-yl)) + ) + )) + ,{- xh > yh -} yl == 0 ? ( let (t2,t1) = quotRem xh yh + in lift (mkW2 0 (fromIntegral t2), W2 t1 xl) + , yh == 0 && yl == maxBound + ? ( let z = fromIntegral xh + (t2,t1) = addWithCarry z xl + in + t2 == 0 ? + ( t1 == maxBound ? + ( tup2 ((mkW2 0 z) + 1, 0) + , tup2 (mkW2 0 z, mkW2 0 t1) + ) + , t1 == maxBound ? + ( tup2 ((mkW2 0 z) + 2, 1) + , t1 == xor maxBound 1 ? + ( tup2 ((mkW2 0 z) + 2, 0) + , tup2 ((mkW2 0 z) + 1, mkW2 0 (t1+1)) + ) + ) + ) + , yh == 0 ? ( let (t2,t1) = untup2 (div1 xh xl yl) + in tup2 (t2, mkW2 0 t1) + , {- otherwise -} + let t1 = countLeadingZeros xh + t2 = countLeadingZeros yh + z = shiftR xh (finiteBitSize (undefined::Exp a) - t2) + u = shiftL x t2 + v = shiftL y t2 + W2 hhh hll = unlift u :: BigWord (Exp a) (Exp b) + W2 lhh lll = unlift v :: BigWord (Exp a) (Exp b) + -- -- z hhh hll / lhh lll + (q1, r1) = div2 z hhh lhh + (t4, t3) = mulWithCarry (fromIntegral q1) lll + t5 = mkW2 (fromIntegral t4) t3 + t6 = mkW2 r1 hll + (t8, t7) = addWithCarry t6 v + (t10, t9) = addWithCarry t7 v + loWord w = let W2 _ l = unlift w :: BigWord (Exp a) (Exp b) + in l + qr2 = t5 > t6 ? + ( loWord t8 == 0 ? + ( t7 >= t5 ? + ( tup2 (q1-1, t7-t5) + , loWord t10 == 0 ? + ( tup2 (q1-2, t9-t5) + , tup2 (q1-2, (maxBound-t5) + t9 + 1) + ) + ) + , tup2 (q1-1, (maxBound-t5) + t7 + 1) + ) + , tup2 (q1, t6-t5) + ) + (q2,r2) = unlift qr2 + in + t1 == t2 ? ( tup2 (1, x-y) + , lift (mkW2 0 (fromIntegral q2), shiftR r2 t2) + ) + ))) + )) + + -- TLM: This is really unfortunate that we can not share expressions + -- between each part of the loop ): Maybe LLVM will be smart enough + -- to share them. + div1 :: Exp a -> Exp b -> Exp b -> Exp (BigWord a b, b) + div1 hhh hll by = go hhh hll 0 + where + go :: Exp a -> Exp b -> Exp (BigWord a b) -> Exp (BigWord a b, b) + go h l c = uncurry3 after $ while (not . uncurry3 done) (uncurry3 body) (lift (h,l,c)) + + (t2, t1) = quotRem maxBound by + done h l _ = z == 0 + where + h1 = fromIntegral h + (t4, t3) = mulWithCarry h1 (t1 + 1) + (t6, _t5) = addWithCarry t3 l + z = t4 + t6 + + body h l c = lift (fromIntegral z, t5, c + (mkW2 (fromIntegral t8) t7)) + where + h1 = fromIntegral h + (t4, t3) = mulWithCarry h1 (t1 + 1) + (t6, t5) = addWithCarry t3 l + z = t4 + t6 + (t8, t7) = mulWithCarry h1 t2 + + after h l c = lift (c + mkW2 (fromIntegral t8) t7 + mkW2 0 t10, t9) + where + h1 = fromIntegral h + (_t4, t3) = mulWithCarry h1 (t1 + 1) + (_t6, t5) = addWithCarry t3 l + (t8, t7) = mulWithCarry h1 t2 + (t10, t9) = quotRem t5 by + + + div2 :: Exp a -> Exp a -> Exp a -> (Exp a, Exp a) + div2 hhh hll by = go hhh hll (tup2 (0,0)) + where + go :: Exp a -> Exp a -> Exp (a,a) -> (Exp a, Exp a) + go h l c = uncurry3 after $ while (not . uncurry3 done) (uncurry3 body) (lift (h,l,c)) + + (t2, t1) = quotRem maxBound by + + done :: Exp a -> Exp a -> Exp (a,a) -> Exp Bool + done h l _ = z == 0 + where + (t4, t3) = mulWithCarry h (t1 + 1) + (t6, _t5) = addWithCarry t3 l + z = t4 + t6 + + body :: Exp a -> Exp a -> Exp (a,a) -> Exp (a, a, (a,a)) + body h l c = lift (z, t5, (addT (unlift c) (t8,t7))) + where + (t4, t3) = mulWithCarry h (t1 + 1) + (t6, t5) = addWithCarry t3 l + z = t4 + t6 + (t8, t7) = mulWithCarry h t2 + + after :: Exp a -> Exp a -> Exp (a,a) -> (Exp a, Exp a) + after h l c = (snd q, t9) + where + (_t4, t3) = mulWithCarry h (t1 + 1) + (_t6, t5) = addWithCarry t3 l + (t8, t7) = mulWithCarry h t2 + (t10, t9) = quotRem t5 by + q = addT (unlift (addT (unlift c) (t8, t7))) (0, t10) + + addT :: (Exp a, Exp a) -> (Exp a, Exp a) -> Exp (a,a) + addT (lhh, lhl) (llh, lll) = + let (t4', t3') = addWithCarry lhl lll + in lift (lhh + llh + t4', t3') + + uncurry3 f (untup3 -> (a,b,c)) = f a b c + + +instance ( Integral a, FiniteBits a, FromIntegral a b, Num2 (Exp a) + , Integral b, FiniteBits b, FromIntegral b a, Num2 (Exp b) + , Elt (Signed a) + , Elt (BigInt (Signed a) b) + , Exp (Signed a) ~ Signed (Exp a) + , BigWordCtx a b + ) + => Num2 (Exp (BigWord a b)) where + type Signed (Exp (BigWord a b)) = Exp (BigInt (Signed a) b) + type Unsigned (Exp (BigWord a b)) = Exp (BigWord a b) + -- + signed (unlift -> W2 (hi::Exp a) lo) = mkI2 (signed hi) lo + unsigned = id + -- + addWithCarry (unlift -> W2 xh xl) (unlift -> W2 yh yl) = (mkW2 0 w, mkW2 v u) + where + (t1, u) = addWithCarry xl yl + (t3, t2) = addWithCarry xh (fromIntegral t1) + (t4, v) = addWithCarry t2 yh + w = fromIntegral (t3 + t4) + + mulWithCarry (unlift -> W2 xh xl) (unlift -> W2 yh yl) = + ( mkW2 (hhh + fromIntegral (shiftR t9 y) + shiftL x z) (shiftL t9 z .|. shiftR t3 y) + , mkW2 (fromIntegral t3) lll) + where + (llh, lll) = mulWithCarry xl yl + (hlh, hll) = mulWithCarry (fromIntegral xh) yl + (lhh, lhl) = mulWithCarry xl (fromIntegral yh) + (hhh, hhl) = mulWithCarry xh yh + (t2, t1) = addWithCarry llh hll + (t4, t3) = addWithCarry t1 lhl + (t6, t5) = addWithCarry (fromIntegral hhl) (t2 + t4) + (t8, t7) = addWithCarry t5 lhh + (t10, t9) = addWithCarry t7 hlh + x = fromIntegral (t6 + t8 + t10) + y = finiteBitSize (undefined::Exp a) + z = finiteBitSize (undefined::Exp b) - y + + +instance ( Integral a, FiniteBits a, FromIntegral a b + , Integral b, FiniteBits b, FromIntegral b a + , BigWordCtx a b + ) + => Bits (BigWord a b) where + + isSigned _ = constant False + + (unlift -> W2 xh xl) .&. (unlift -> W2 yh yl) = mkW2 (xh .&. yh) (xl .&. yl) + (unlift -> W2 xh xl) .|. (unlift -> W2 yh yl) = mkW2 (xh .|. yh) (xl .|. yl) + (unlift -> W2 xh xl) `xor` (unlift -> W2 yh yl) = mkW2 (xh `xor` yh) (xl `xor` yl) + complement (unlift -> W2 hi lo) = mkW2 (complement hi) (complement lo) + + shiftL (unlift -> W2 hi lo) x = + if y > 0 + then mkW2 (shiftL hi x .|. fromIntegral (shiftR lo y)) (shiftL lo x) + else mkW2 (fromIntegral (shiftL lo (negate y))) (0::Exp b) + where + y = finiteBitSize (undefined::Exp b) - x + + shiftR (unlift -> W2 hi lo) x = mkW2 hi' lo' + where + hi' = shiftR hi x + lo' = if y >= 0 then shiftL (fromIntegral hi) y .|. shiftR lo x + else z + -- + y = finiteBitSize (undefined::Exp b) - x + z = shiftR (fromIntegral hi) (negate y) + + rotateL (unlift -> W2 hi lo) x = + if y >= 0 + then mkW2 (fromIntegral (shiftL lo y) .|. shiftR hi z) + (shiftL (fromIntegral hi) (finiteBitSize (undefined::Exp b) - z) .|. shiftR lo z) + else mkW2 (fromIntegral (shiftR lo (negate y)) .|. shiftL hi x) + (shift (fromIntegral hi) (finiteBitSize (undefined::Exp b) - z) .|. shiftL lo x .|. shiftR lo z) + where + y = x - finiteBitSize (undefined::Exp b) + z = finiteBitSize (undefined::Exp (BigWord a b)) - x + + rotateR x y = rotateL x (finiteBitSize (undefined::Exp (BigWord a b)) - y) + + bit n = + if m >= 0 + then mkW2 (bit m) 0 + else mkW2 0 (bit n) + where + m = n - finiteBitSize (undefined::Exp b) + + testBit (unlift -> W2 hi lo) n = + if m >= 0 + then testBit hi m + else testBit lo n + where + m = n - finiteBitSize (undefined::Exp b) + + setBit (unlift -> W2 hi lo) n = + if m >= 0 + then mkW2 (setBit hi m) lo + else mkW2 hi (setBit lo n) + where + m = n - finiteBitSize (undefined::Exp b) + + clearBit (unlift -> W2 hi lo) n = + if m >= 0 + then mkW2 (clearBit hi m) lo + else mkW2 hi (clearBit lo n) + where + m = n - finiteBitSize (undefined::Exp b) + + complementBit (unlift -> W2 hi lo) n = + if m >= 0 + then mkW2 (complementBit hi m) lo + else mkW2 hi (complementBit lo n) + where + m = n - finiteBitSize (undefined::Exp b) + + popCount (unlift -> W2 hi lo) = popCount hi + popCount lo + + +instance ( Integral a, FiniteBits a, FromIntegral a b + , Integral b, FiniteBits b, FromIntegral b a + , BigWordCtx a b + ) + => FiniteBits (BigWord a b) where + finiteBitSize _ = finiteBitSize (undefined::Exp a) + + finiteBitSize (undefined::Exp b) + + countLeadingZeros (unlift -> W2 hi lo) = + hlz == wsib ? (wsib + llz, hlz) + where + hlz = countLeadingZeros hi + llz = countLeadingZeros lo + wsib = finiteBitSize (undefined::Exp a) + + countTrailingZeros (unlift -> W2 hi lo) = + ltz == wsib ? (wsib + htz, ltz) + where + ltz = countTrailingZeros lo + htz = countTrailingZeros hi + wsib = finiteBitSize (undefined::Exp b) + + +-- BigInt +-- ------ + +type BigIntCtx hi lo = + ( Elt hi, Elt lo, Elt (BigInt hi lo) + , hi ~ Signed hi + , lo ~ Unsigned lo + , hi ~ Signed (Unsigned hi) + , Exp hi ~ Signed (Exp hi) + , Exp lo ~ Unsigned (Exp lo) + ) + +mkI2 :: (Elt a, Elt b, Elt (BigInt a b)) => Exp a -> Exp b -> Exp (BigInt a b) +mkI2 a b = lift (I2 a b) + + +instance (Bounded a, Bounded b, Elt (BigInt a b)) => P.Bounded (Exp (BigInt a b)) where + minBound = mkI2 minBound minBound + maxBound = mkI2 maxBound maxBound + + +instance (Eq a, Eq b, Elt (BigInt a b)) => Eq (BigInt a b) where + (unlift -> I2 xh xl) == (unlift -> I2 yh yl) = xh == yh && xl == yl + (unlift -> I2 xh xl) /= (unlift -> I2 yh yl) = xh /= yh || xl /= yl + + +instance (Ord a, Ord b, Elt (BigInt a b)) => Ord (BigInt a b) where + (unlift -> I2 xh xl) < (unlift -> I2 yh yl) = xh == yh ? ( xl < yl, xh < yh ) + (unlift -> I2 xh xl) > (unlift -> I2 yh yl) = xh == yh ? ( xl > yl, xh > yh ) + (unlift -> I2 xh xl) <= (unlift -> I2 yh yl) = xh == yh ? ( xl <= yl, xh <= yh ) + (unlift -> I2 xh xl) >= (unlift -> I2 yh yl) = xh == yh ? ( xl >= yl, xh >= yh ) + + +instance ( Num a, Ord a + , Num b, Ord b, Bounded b + , Num2 (Exp (BigInt a b)) + , Num2 (Exp (BigWord (Unsigned a) b)) + , Num (BigWord (Unsigned a) b) + , P.Num (BigInt a b) + , BigIntCtx a b + ) + => P.Num (Exp (BigInt a b)) where + negate (unlift -> I2 hi lo) = + if lo == 0 + then mkI2 (negate hi) 0 + else mkI2 (negate (hi+1)) (negate lo) + + signum (unlift -> I2 hi lo :: BigInt (Exp a) (Exp b)) = + if hi < 0 then mkI2 (-1) maxBound else + if hi == 0 then if lo == 0 then 0 else 1 + else mkI2 0 1 + + abs x = + if x < 0 then negate x + else x + + fromInteger = constant . fromInteger + + {-# SPECIALIZE (+) :: Exp Int128 -> Exp Int128 -> Exp Int128 #-} + (+) | Just Refl <- matchInt128 (undefined::BigInt a b) = CPU.addInt128# $ PTX.addInt128# add + | otherwise = add + where + add :: Exp (BigInt a b) -> Exp (BigInt a b) -> Exp (BigInt a b) + add (unlift -> I2 xh xl) (unlift -> I2 yh yl) = mkI2 hi lo + where + lo = xl + yl + hi = xh + yh + if lo < xl then 1 else 0 + + {-# SPECIALIZE (-) :: Exp Int128 -> Exp Int128 -> Exp Int128 #-} + (-) | Just Refl <- matchInt128 (undefined::BigInt a b) = CPU.subInt128# $ PTX.subInt128# (\x y -> x + negate y) + | otherwise = \x y -> x + negate y + + {-# SPECIALIZE (*) :: Exp Int128 -> Exp Int128 -> Exp Int128 #-} + (*) | Just Refl <- matchInt128 (undefined::BigInt a b) = CPU.mulInt128# $ PTX.mulInt128# mul + | otherwise = mul + where + mul :: Exp (BigInt a b) -> Exp (BigInt a b) -> Exp (BigInt a b) + mul x y = signed (unsigned x * unsigned y) + + +instance ( Integral a + , Integral b + , Num (BigInt a b) + , Eq (BigWord (Unsigned a) b) + , Integral (BigWord (Unsigned a) b) + , Num2 (Exp (BigInt a b)) + , Num2 (Exp (BigWord (Unsigned a) b)) + , BigIntCtx a b + ) + => P.Integral (Exp (BigInt a b)) where + toInteger = error "Prelude.toInteger not supported for Accelerate types" + + {-# SPECIALIZE quot :: Exp Int128 -> Exp Int128 -> Exp Int128 #-} + quot | Just Refl <- matchInt128 (undefined::BigInt a b) = CPU.quotInt128# $ PTX.quotInt128# go + | otherwise = go + where + go x y = P.fst (quotRem x y) + + {-# SPECIALIZE rem :: Exp Int128 -> Exp Int128 -> Exp Int128 #-} + rem | Just Refl <- matchInt128 (undefined::BigInt a b) = CPU.remInt128# $ PTX.remInt128# go + | otherwise = go + where + go x y = P.snd (quotRem x y) + + {-# SPECIALISE quotRem :: Exp Int128 -> Exp Int128 -> (Exp Int128, Exp Int128) #-} + quotRem | Just Refl <- matchInt128 (undefined::BigInt a b) = untup2 $$ CPU.quotRemInt128# $ PTX.quotRemInt128# quotRem' + | otherwise = untup2 $$ quotRem' + where + quotRem' x y = + if x < 0 + then if y < 0 + then + let (q,r) = quotRem (negate (unsigned x)) (negate (unsigned y)) + in tup2 (signed q, signed (negate r)) + else + let (q,r) = quotRem (negate (unsigned x)) (unsigned y) + in tup2 (signed (negate q), signed (negate r)) + else if y < 0 + then + let (q,r) = quotRem (unsigned x) (negate (unsigned y)) + in tup2 (signed (negate q), signed r) + else + let (q,r) = quotRem (unsigned x) (unsigned y) + in tup2 (signed q, signed r) + + {-# SPECIALIZE div :: Exp Int128 -> Exp Int128 -> Exp Int128 #-} + {-# SPECIALIZE mod :: Exp Int128 -> Exp Int128 -> Exp Int128 #-} + div x y = P.fst (divMod x y) + mod x y = P.snd (divMod x y) + + {-# SPECIALIZE divMod :: Exp Int128 -> Exp Int128 -> (Exp Int128, Exp Int128) #-} + divMod x y = untup2 $ + if x < 0 + then if y < 0 + then let (q,r) = quotRem (negate (unsigned x)) (negate (unsigned y)) + in tup2 (signed q, signed (negate r)) + else let (q,r) = quotRem (negate (unsigned x)) (unsigned y) + q' = signed (negate q) + r' = signed (negate r) + in + if r == 0 then tup2 (q', r') + else tup2 (q'-1, r'+y) + else if y < 0 + then let (q,r) = quotRem (unsigned x) (negate (unsigned y)) + q' = signed (negate q) + r' = signed r + in + if r == 0 + then tup2 (q', r') + else tup2 (q'-1, r'+y) + else let (q,r) = quotRem (unsigned x) (unsigned y) + in tup2 (signed q, signed r) + + +instance ( FiniteBits a, Integral a, FromIntegral a b, FromIntegral a (Signed b) + , FiniteBits b, Integral b, FromIntegral b a + , Bits (Signed b), Integral (Signed b), FromIntegral (Signed b) b + , Num2 (Exp (BigInt a b)) + , Num2 (Exp (BigWord (Unsigned a) b)) + , Bits (BigWord (Unsigned a) b) + , FiniteBits (BigInt a b) + , BigIntCtx a b + ) + => Bits (BigInt a b) where + isSigned _ = constant True + + (unlift -> I2 xh xl) .&. (unlift -> I2 yh yl) = mkI2 (xh .&. yh) (xl .&. yl) + (unlift -> I2 xh xl) .|. (unlift -> I2 yh yl) = mkI2 (xh .|. yh) (xl .|. yl) + (unlift -> I2 xh xl) `xor` (unlift -> I2 yh yl) = mkI2 (xh `xor` yh) (xl `xor` yl) + complement (unlift -> I2 hi lo) = mkI2 (complement hi) (complement lo) + + shiftL (unlift -> I2 hi lo) x = + if y > 0 + then mkI2 (shiftL hi x .|. fromIntegral (shiftR lo y)) (shiftL lo x) + else mkI2 (fromIntegral (shiftL lo (negate y))) 0 + where + y = finiteBitSize (undefined::Exp b) - x + + shiftR (unlift -> I2 hi lo) x = mkI2 hi' lo' + where + hi' = shiftR hi x + lo' = if y >= 0 then shiftL (fromIntegral hi) y .|. shiftR lo x + else z + -- + y = finiteBitSize (undefined::Exp b) - x + z = fromIntegral (shiftR (fromIntegral hi :: Exp (Signed b)) (negate y)) + + rotateL x y = signed (rotateL (unsigned x) y) + rotateR x y = rotateL x (finiteBitSize (undefined::Exp (BigInt a b)) - y) + + bit n = + if m >= 0 then mkI2 (bit m) 0 + else mkI2 0 (bit n) + where + m = n - finiteBitSize (undefined::Exp b) + + testBit (unlift -> I2 hi lo) n = + if m >= 0 then testBit hi m + else testBit lo n + where + m = n - finiteBitSize (undefined::Exp b) + + setBit (unlift -> I2 hi lo) n = + if m >= 0 then mkI2 (setBit hi m) lo + else mkI2 hi (setBit lo n) + where + m = n - finiteBitSize (undefined::Exp b) + + clearBit (unlift -> I2 hi lo) n = + if m >= 0 then mkI2 (clearBit hi m) lo + else mkI2 hi (clearBit lo n) + where + m = n - finiteBitSize (undefined::Exp b) + + complementBit (unlift -> I2 hi lo) n = + if m >= 0 then mkI2 (complementBit hi m) lo + else mkI2 hi (complementBit lo n) + where + m = n - finiteBitSize (undefined::Exp b) + + popCount (unlift -> I2 hi lo) = popCount hi + popCount lo + + +instance ( FiniteBits a + , FiniteBits b + , Bits (BigInt a b) + , Num2 (Exp (BigInt a b)) + , FiniteBits (BigWord (Unsigned a) b) + , BigIntCtx a b + ) + => FiniteBits (BigInt a b) where + finiteBitSize _ = finiteBitSize (undefined::Exp a) + + finiteBitSize (undefined::Exp b) + + countLeadingZeros = countLeadingZeros . unsigned + countTrailingZeros = countTrailingZeros . unsigned + + +instance ( Ord a + , Num a + , Num2 (Exp a) + , Ord (BigInt a b) + , Num (BigInt a b) + , Bits (BigInt a b) + , Bounded (BigWord (Unsigned a) b) + , Num (BigWord (Unsigned a) b) + , Num2 (Exp (BigWord (Unsigned a) b)) + , Elt (Unsigned a) + , Exp (Unsigned a) ~ Unsigned (Exp a) + , BigIntCtx a b + ) + => Num2 (Exp (BigInt a b)) where + type Signed (Exp (BigInt a b)) = Exp (BigInt a b) + type Unsigned (Exp (BigInt a b)) = Exp (BigWord (Unsigned a) b) + -- + signed = id + unsigned (unlift -> I2 (hi::Exp a) lo) = mkW2 (unsigned hi) lo + -- + addWithCarry x y = (c, r) + where + t1 = if x < 0 then maxBound else minBound + t2 = if y < 0 then maxBound else minBound + (t3, r) = addWithCarry (unsigned x) (unsigned y) + c = signed (t1+t2+t3) + + mulWithCarry x@(unlift -> I2 xh (_::Exp b)) y@(unlift -> I2 yh (_::Exp b)) = (hi,lo) + where + t1 = complement y + 1 + t2 = complement x + 1 + (t3, lo) = mulWithCarry (unsigned x) (unsigned y) + t4 = signed t3 + hi = if xh < 0 + then if yh < 0 + then t4 + t1 + t2 + else t4 + t1 + else if yh < 0 + then t4 + t2 + else t4 + + +-- Num2 +-- ---- + +instance Num2 (Exp Int8) where + type Signed (Exp Int8) = Exp Int8 + type Unsigned (Exp Int8) = Exp Word8 + -- + signed = id + unsigned = fromIntegral + addWithCarry = defaultUnwrapped ((+) :: Exp Int16 -> Exp Int16 -> Exp Int16) + mulWithCarry = defaultUnwrapped ((*) :: Exp Int16 -> Exp Int16 -> Exp Int16) + +instance Num2 (Exp Word8) where + type Signed (Exp Word8) = Exp Int8 + type Unsigned (Exp Word8) = Exp Word8 + -- + signed = fromIntegral + unsigned = id + addWithCarry = defaultUnwrapped ((+) :: Exp Word16 -> Exp Word16 -> Exp Word16) + mulWithCarry = defaultUnwrapped ((*) :: Exp Word16 -> Exp Word16 -> Exp Word16) + +instance Num2 (Exp Int16) where + type Signed (Exp Int16) = Exp Int16 + type Unsigned (Exp Int16) = Exp Word16 + -- + signed = id + unsigned = fromIntegral + addWithCarry = defaultUnwrapped ((+) :: Exp Int32 -> Exp Int32 -> Exp Int32) + mulWithCarry = defaultUnwrapped ((*) :: Exp Int32 -> Exp Int32 -> Exp Int32) + +instance Num2 (Exp Word16) where + type Signed (Exp Word16) = Exp Int16 + type Unsigned (Exp Word16) = Exp Word16 + -- + signed = fromIntegral + unsigned = id + addWithCarry = defaultUnwrapped ((+) :: Exp Word32 -> Exp Word32 -> Exp Word32) + mulWithCarry = defaultUnwrapped ((*) :: Exp Word32 -> Exp Word32 -> Exp Word32) + +instance Num2 (Exp Int32) where + type Signed (Exp Int32) = Exp Int32 + type Unsigned (Exp Int32) = Exp Word32 + -- + signed = id + unsigned = fromIntegral + addWithCarry = defaultUnwrapped ((+) :: Exp Int64 -> Exp Int64 -> Exp Int64) + mulWithCarry = defaultUnwrapped ((*) :: Exp Int64 -> Exp Int64 -> Exp Int64) + +instance Num2 (Exp Word32) where + type Signed (Exp Word32) = Exp Int32 + type Unsigned (Exp Word32) = Exp Word32 + -- + signed = fromIntegral + unsigned = id + addWithCarry = defaultUnwrapped ((+) :: Exp Word64 -> Exp Word64 -> Exp Word64) + mulWithCarry = defaultUnwrapped ((*) :: Exp Word64 -> Exp Word64 -> Exp Word64) + +instance Num2 (Exp Int64) where + type Signed (Exp Int64) = Exp Int64 + type Unsigned (Exp Int64) = Exp Word64 + -- + signed = id + unsigned = fromIntegral + addWithCarry = untup2 $$ CPU.addWithCarryInt64# $ PTX.addWithCarryInt64# awc + where + awc x y = tup2 (hi,lo) + where + extX = x < 0 ? (maxBound, 0) + extY = y < 0 ? (maxBound, 0) + (hi',lo) = unsigned x `addWithCarry` unsigned y + hi = signed (hi' + extX + extY) + + mulWithCarry = untup2 $$ CPU.mulWithCarryInt64# $ PTX.mulWithCarryInt64# mwc + where + mwc x y = tup2 (hi,lo) + where + extX = x < 0 ? (negate y, 0) + extY = y < 0 ? (negate x, 0) + (hi',lo) = unsigned x `mulWithCarry` unsigned y + hi = signed hi' + extX + extY + +instance Num2 (Exp Word64) where + type Signed (Exp Word64) = Exp Int64 + type Unsigned (Exp Word64) = Exp Word64 + -- + signed = fromIntegral + unsigned = id + addWithCarry = untup2 $$ CPU.addWithCarryWord64# $ PTX.addWithCarryWord64# awc + where + awc x y = tup2 (hi,lo) + where + lo = x + y + hi = lo < x ? (1,0) + + mulWithCarry = untup2 $$ CPU.mulWithCarryWord64# $ PTX.mulWithCarryWord64# mwc + where + mwc x y = tup2 (hi,lo) + where + xHi = shiftR x 32 + yHi = shiftR y 32 + xLo = x .&. 0xFFFFFFFF + yLo = y .&. 0xFFFFFFFF + hi0 = xHi * yHi + lo0 = xLo * yLo + p1 = xHi * yLo + p2 = xLo * yHi + (uHi1, uLo) = addWithCarry (fromIntegral p1) (fromIntegral p2) + (uHi2, lo') = addWithCarry (fromIntegral (shiftR lo0 32)) uLo + hi = hi0 + fromIntegral (uHi1::Exp Word32) + fromIntegral uHi2 + shiftR p1 32 + shiftR p2 32 + lo = shiftL (fromIntegral lo') 32 .|. (lo0 .&. 0xFFFFFFFF) + + +defaultUnwrapped + :: ( FiniteBits w, Bits ww, Integral w, Integral ww + , FromIntegral w ww, FromIntegral ww w, FromIntegral ww w', Unsigned (Exp w) ~ Exp w' + ) + => (Exp ww -> Exp ww -> Exp ww) + -> Exp w + -> Exp w + -> (Exp w, Unsigned (Exp w)) +defaultUnwrapped op x y = (hi, lo) + where + r = fromIntegral x `op` fromIntegral y + lo = fromIntegral r + hi = fromIntegral (r `shiftR` finiteBitSize x) + + +-- Utilities +-- --------- + +matchInt128 :: Elt (BigInt a b) => BigInt a b -> Maybe (BigInt a b :~: Int128) +matchInt128 t + | Just Refl <- matchTupleType (eltType t) (eltType (undefined::Int128)) + = gcast Refl +matchInt128 _ + = Nothing + +matchWord128 :: Elt (BigWord a b) => BigWord a b -> Maybe (BigWord a b :~: Word128) +matchWord128 t + | Just Refl <- matchTupleType (eltType t) (eltType (undefined::Word128)) + = gcast Refl +matchWord128 _ + = Nothing + + +-- FromIntegral conversions +-- ------------------------ + +$(runQ $ do + let + lilNums = [ 32, 64 ] + bigNums = [ (32,64), (64,64), (32,128), (64,128), (32,192), (128,128), (256,256) ] + + wordT :: Int -> Q Type + wordT = return . ConT . mkName . printf "Word%d" + + intT :: Int -> Q Type + intT = return . ConT . mkName . printf "Int%d" + + bigWordT :: (Int,Int) -> Q Type + bigWordT (hi,lo) = wordT (hi+lo) + + bigIntT :: (Int,Int) -> Q Type + bigIntT (hi,lo) = intT (hi+lo) + + thFromIntegral1 :: (Int,Int) -> Q [Dec] + thFromIntegral1 big = + [d| + -- signed/unsigned bignum conversions at same width + instance FromIntegral $(bigIntT big) $(bigIntT big) where + fromIntegral = id + + instance FromIntegral $(bigWordT big) $(bigWordT big) where + fromIntegral = id + + instance FromIntegral $(bigIntT big) $(bigWordT big) where + fromIntegral (unlift -> I2 hi lo) = mkW2 (fromIntegral hi) lo + + instance FromIntegral $(bigWordT big) $(bigIntT big) where + fromIntegral (unlift -> W2 hi lo) = mkI2 (fromIntegral hi) lo + |] + + thFromIntegral2 :: (Int,Int) -> Int -> Q [Dec] + thFromIntegral2 big@(bigH,bigL) little = + [d| + -- convert from primitive type to bignum type + instance FromIntegral $(wordT little) $(bigWordT big) where + fromIntegral x = mkW2 0 (fromIntegral x) + + instance FromIntegral $(wordT little) $(bigIntT big) where + fromIntegral x = mkI2 0 (fromIntegral x) + + instance FromIntegral $(intT little) $(bigWordT big) where + fromIntegral x@(fromIntegral -> x') = + if x < 0 then mkW2 maxBound x' + else mkW2 0 x' + + instance FromIntegral $(intT little) $(bigIntT big) where + fromIntegral x@(fromIntegral -> x') = + if x < 0 then mkI2 (-1) x' + else mkI2 0 x' + + -- convert from bignum type to primitive type + instance FromIntegral $(bigWordT big) $(wordT little) where + fromIntegral x = + let W2 _ lo = unlift x :: BigWord (Exp $(wordT bigH)) (Exp $(wordT bigL)) + in fromIntegral lo + + instance FromIntegral $(bigWordT big) $(intT little) where + fromIntegral x = + let W2 _ lo = unlift x :: BigWord (Exp $(wordT bigH)) (Exp $(wordT bigL)) + in fromIntegral lo + + instance FromIntegral $(bigIntT big) $(wordT little) where + fromIntegral x = + let I2 _ lo = unlift x :: BigInt (Exp $(intT bigH)) (Exp $(wordT bigL)) + in fromIntegral lo + + instance FromIntegral $(bigIntT big) $(intT little) where + fromIntegral x = + let I2 _ lo = unlift x :: BigInt (Exp $(intT bigH)) (Exp $(wordT bigL)) + in fromIntegral lo + |] + -- + d1 <- sequence [ thFromIntegral1 x | x <- bigNums ] + d2 <- sequence [ thFromIntegral2 x y | x <- bigNums, y <- lilNums ] + -- + return $ P.concat (d1 P.++ d2) + ) + diff --git a/src/Data/Array/Accelerate/Internal/Orphans/Elt.hs b/src/Data/Array/Accelerate/Internal/Orphans/Elt.hs new file mode 100644 --- /dev/null +++ b/src/Data/Array/Accelerate/Internal/Orphans/Elt.hs @@ -0,0 +1,83 @@ +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE UndecidableInstances #-} +{-# OPTIONS_GHC -fno-warn-orphans #-} +-- | +-- Module : Data.Array.Accelerate.Internal.Orphans.Elt +-- Copyright : [2016] Trevor L. McDonell +-- License : BSD3 +-- +-- Maintainer : Trevor L. McDonell +-- Stability : experimental +-- Portability : non-portable (GHC extensions) +-- +-- Orphan Elt instances for BigWord and BigInt +-- + +module Data.Array.Accelerate.Internal.Orphans.Elt () + where + +import Data.Array.Accelerate.Internal.BigInt +import Data.Array.Accelerate.Internal.BigWord + +import Data.Array.Accelerate +import Data.Array.Accelerate.Array.Sugar +import Data.Array.Accelerate.Product +import Data.Array.Accelerate.Smart + + +type instance EltRepr (BigInt a b) = EltRepr (a,b) +type instance EltRepr (BigWord a b) = EltRepr (a,b) + + +instance (Elt a, Elt b, Show (BigWord a b)) => Elt (BigWord a b) where + eltType _ = eltType (undefined :: (a,b)) + toElt w = let (a,b) = toElt w in W2 a b + fromElt (W2 a b) = fromElt (a,b) + +instance (cst a, cst b) => IsProduct cst (BigWord a b) where + type ProdRepr (BigWord a b) = ProdRepr (a,b) + fromProd cst (W2 a b) = fromProd cst (a,b) + toProd cst w = let (a,b) = toProd cst w in W2 a b + prod cst _ = prod cst (undefined :: (a,b)) + +instance (Lift Exp a, Lift Exp b, Elt (Plain a), Elt (Plain b), Show (BigWord (Plain a) (Plain b))) + => Lift Exp (BigWord a b) where + type Plain (BigWord a b) = BigWord (Plain a) (Plain b) + lift (W2 a b) = Exp $ Tuple (NilTup `SnocTup` lift a `SnocTup` lift b) + +instance (Elt a, Elt b, Show (BigWord a b)) => Unlift Exp (BigWord (Exp a) (Exp b)) where + unlift w = + let a = Exp $ SuccTupIdx ZeroTupIdx `Prj` w + b = Exp $ ZeroTupIdx `Prj` w + in + W2 a b + + +instance (Elt a, Elt b, Show (BigInt a b)) => Elt (BigInt a b) where + eltType _ = eltType (undefined :: (a,b)) + toElt w = let (a,b) = toElt w in I2 a b + fromElt (I2 a b) = fromElt (a,b) + +instance (cst a, cst b) => IsProduct cst (BigInt a b) where + type ProdRepr (BigInt a b) = ProdRepr (a,b) + fromProd cst (I2 a b) = fromProd cst (a,b) + toProd cst w = let (a,b) = toProd cst w in I2 a b + prod cst _ = prod cst (undefined :: (a,b)) + +instance (Lift Exp a, Lift Exp b, Elt (Plain a), Elt (Plain b), Show (BigInt (Plain a) (Plain b))) + => Lift Exp (BigInt a b) where + type Plain (BigInt a b) = BigInt (Plain a) (Plain b) + lift (I2 a b) = Exp $ Tuple (NilTup `SnocTup` lift a `SnocTup` lift b) + +instance (Elt a, Elt b, Show (BigInt a b)) => Unlift Exp (BigInt (Exp a) (Exp b)) where + unlift w = + let a = Exp $ SuccTupIdx ZeroTupIdx `Prj` w + b = Exp $ ZeroTupIdx `Prj` w + in + I2 a b + diff --git a/test/Main.hs b/test/Main.hs new file mode 100644 --- /dev/null +++ b/test/Main.hs @@ -0,0 +1,698 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE FunctionalDependencies #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeFamilies #-} +{-# OPTIONS_GHC -fno-warn-orphans #-} + +module Main where + +import Data.Bits +import Data.Int +import Data.Proxy +import Data.Word +import Test.Tasty +import Test.Tasty.QuickCheck hiding ( (.&.) ) +import Text.Printf + +import Data.Array.Accelerate.Data.BigInt +import Data.Array.Accelerate.Data.BigWord + +import Data.Array.Accelerate ( Arrays, Acc, Scalar, Elt, Exp, Lift, Plain ) +import Data.Array.Accelerate.Debug ( accInit ) +import qualified Data.Array.Accelerate as A +import qualified Data.Array.Accelerate.Data.Bits as A +import qualified Data.Array.Accelerate.Interpreter as I +#ifdef ACCELERATE_LLVM_NATIVE_BACKEND +import qualified Data.Array.Accelerate.LLVM.Native as CPU +#endif +#ifdef ACCELERATE_LLVM_PTX_BACKEND +import qualified Data.Array.Accelerate.LLVM.PTX as PTX +#endif + + +main :: IO () +main = do + accInit + defaultMain + $ localOption (QuickCheckTests 10000) + $ testGroup "accelerate-bignum" + [ testGroup "base" + [ testGroup "Num2" + [ testNum2 (Proxy::Proxy Word8) + , testNum2 (Proxy::Proxy Word16) + , testNum2 (Proxy::Proxy Word32) + , testNum2 (Proxy::Proxy Word64) + , testNum2 (Proxy::Proxy Int8) + , testNum2 (Proxy::Proxy Int16) + , testNum2 (Proxy::Proxy Int32) + , testNum2 (Proxy::Proxy Int64) + ] + , testMain (Proxy::Proxy U64) + , testMain (Proxy::Proxy I64) + , testMain (Proxy::Proxy UU64) + , testMain (Proxy::Proxy II64) + ] + , testGroup "accelerate" + [ testAcc Interpreter +#ifdef ACCELERATE_LLVM_NATIVE_BACKEND + , testAcc Native +#endif +#ifdef ACCELERATE_LLVM_PTX_BACKEND + , testAcc PTX +#endif + ] + ] + +testAcc :: Backend -> TestTree +testAcc backend = testGroup (show backend) + [ testGroup "Num2" + [ testNum2Acc backend (Proxy::Proxy Word8) + , testNum2Acc backend (Proxy::Proxy Word16) + , testNum2Acc backend (Proxy::Proxy Word32) + , testNum2Acc backend (Proxy::Proxy Word64) + , testNum2Acc backend (Proxy::Proxy Int8) + , testNum2Acc backend (Proxy::Proxy Int16) + , testNum2Acc backend (Proxy::Proxy Int32) + , testNum2Acc backend (Proxy::Proxy Int64) + ] + , testGroup "FromIntegral" + -- little -> big + [ testFromIntegral backend (Proxy::Proxy Int32) (Proxy::Proxy Int128) + , testFromIntegral backend (Proxy::Proxy Int32) (Proxy::Proxy Int192) + , testFromIntegral backend (Proxy::Proxy Int32) (Proxy::Proxy Word128) + , testFromIntegral backend (Proxy::Proxy Int32) (Proxy::Proxy Word192) + , testFromIntegral backend (Proxy::Proxy Int64) (Proxy::Proxy Int128) + , testFromIntegral backend (Proxy::Proxy Int64) (Proxy::Proxy Int192) + , testFromIntegral backend (Proxy::Proxy Int64) (Proxy::Proxy Word128) + , testFromIntegral backend (Proxy::Proxy Int64) (Proxy::Proxy Word192) + , testFromIntegral backend (Proxy::Proxy Word32) (Proxy::Proxy Int128) + , testFromIntegral backend (Proxy::Proxy Word32) (Proxy::Proxy Int192) + , testFromIntegral backend (Proxy::Proxy Word32) (Proxy::Proxy Word128) + , testFromIntegral backend (Proxy::Proxy Word32) (Proxy::Proxy Word192) + , testFromIntegral backend (Proxy::Proxy Word64) (Proxy::Proxy Int128) + , testFromIntegral backend (Proxy::Proxy Word64) (Proxy::Proxy Int192) + , testFromIntegral backend (Proxy::Proxy Word64) (Proxy::Proxy Word128) + , testFromIntegral backend (Proxy::Proxy Word64) (Proxy::Proxy Word192) + -- big -> little + , testFromIntegral backend (Proxy::Proxy Int128) (Proxy::Proxy Int32) + , testFromIntegral backend (Proxy::Proxy Int192) (Proxy::Proxy Int32) + , testFromIntegral backend (Proxy::Proxy Word128) (Proxy::Proxy Int32) + , testFromIntegral backend (Proxy::Proxy Word192) (Proxy::Proxy Int32) + , testFromIntegral backend (Proxy::Proxy Int128) (Proxy::Proxy Int64) + , testFromIntegral backend (Proxy::Proxy Int192) (Proxy::Proxy Int64) + , testFromIntegral backend (Proxy::Proxy Word128) (Proxy::Proxy Int64) + , testFromIntegral backend (Proxy::Proxy Word192) (Proxy::Proxy Int64) + , testFromIntegral backend (Proxy::Proxy Int128) (Proxy::Proxy Word32) + , testFromIntegral backend (Proxy::Proxy Int192) (Proxy::Proxy Word32) + , testFromIntegral backend (Proxy::Proxy Word128) (Proxy::Proxy Word32) + , testFromIntegral backend (Proxy::Proxy Word192) (Proxy::Proxy Word32) + , testFromIntegral backend (Proxy::Proxy Int128) (Proxy::Proxy Word64) + , testFromIntegral backend (Proxy::Proxy Int192) (Proxy::Proxy Word64) + , testFromIntegral backend (Proxy::Proxy Word128) (Proxy::Proxy Word64) + , testFromIntegral backend (Proxy::Proxy Word192) (Proxy::Proxy Word64) + ] + , testMainAcc backend (Proxy::Proxy Word96) + , testMainAcc backend (Proxy::Proxy Word128) + , testMainAcc backend (Proxy::Proxy Int96) + , testMainAcc backend (Proxy::Proxy Int128) + ] + + +testNum2 + :: (Show (ArgType a), Show a, Num2 a, FiniteBits (Unsigned a), Integral a, Integral (Unsigned a), Bounded a) + => proxy a + -> TestTree +testNum2 t = testGroup (showType t) + [ testProperty "addWithCarry" $ prop_addWithCarry t + , testProperty "mulWithCarry" $ prop_mulWithCarry t + ] + +testMain + :: ( Iso a b, Arbitrary a, Show a, Show (ArgType b) + , Ord a, Bounded a, Real a, Integral a, FiniteBits a + , Ord b, Bounded b, Real b, Integral b, FiniteBits b + ) + => proxy b + -> TestTree +testMain t = testGroup (showType t) + [ testProperty "iso" $ prop_iso t + , testGroup "Eq" + [ testProperty "(==)" $ prop_eq t + , testProperty "(/=)" $ prop_neq t + ] + , testGroup "Ord" + [ testProperty "compare" $ prop_compare t + ] + , testGroup "Bounded" + [ testProperty "minBound" $ prop_minBound t + , testProperty "maxBound" $ prop_maxBound t + ] + , testGroup "Enum" + [ testProperty "succ" $ prop_succ t + , testProperty "pred" $ prop_pred t + ] + , testGroup "Num" + [ testProperty "negate" $ prop_negate t + , testProperty "abs" $ prop_abs t + , testProperty "signum" $ prop_signum t + , testProperty "(+)" $ prop_add t + , testProperty "(-)" $ prop_sub t + , testProperty "(*)" $ prop_mul t + , testProperty "fromInteger" $ prop_fromInteger t + ] + , testGroup "Real" + [ testProperty "toRational" $ prop_toRational t + ] + , testGroup "Integral" + [ testProperty "toInteger" $ prop_toInteger t + , testProperty "quot" $ prop_quot t + , testProperty "rem" $ prop_rem t + , testProperty "quotRem" $ prop_quotRem t + , testProperty "div" $ prop_div t + , testProperty "mod" $ prop_mod t + , testProperty "divMod" $ prop_divMod t + ] + , testGroup "Bits" + [ testProperty "complement" $ prop_complement t + , testProperty "xor" $ prop_xor t + , testProperty "(.&.)" $ prop_band t + , testProperty "(.|.)" $ prop_bor t + , testProperty "shiftL" $ prop_shiftL t + , testProperty "shiftR" $ prop_shiftR t + , testProperty "shift" $ prop_shift t + , testProperty "rotateL" $ prop_rotateL t + , testProperty "rotateR" $ prop_rotateR t + , testProperty "rotate" $ prop_rotate t + , testProperty "bit" $ prop_bit t + , testProperty "testBit" $ prop_testBit t + , testProperty "setBit" $ prop_setBit t + , testProperty "clearBit" $ prop_clearBit t + , testProperty "complementBit" $ prop_complementBit t + , testProperty "popCount" $ prop_popCount t + ] + , testGroup "FiniteBits" + [ testProperty "countLeadingZeros" $ prop_clz t + , testProperty "countTrailingZeros" $ prop_ctz t + ] + ] + +testNum2Acc + :: ( Show (ArgType a), Bounded a, Integral a, Integral (Unsigned a), FiniteBits (Unsigned a) + , Elt a, Elt (Unsigned a), Num2 (Exp a) + , Lift Exp (Unsigned (Exp a)), Plain (Unsigned (Exp a)) ~ Unsigned a + ) + => Backend + -> proxy a + -> TestTree +testNum2Acc b t = testGroup (showType t) + [ testProperty "addWithCarry" $ prop_addWithCarry' b t + , testProperty "mulWithCarry" $ prop_mulWithCarry' b t + ] + +testFromIntegral + :: (Show (ArgType a), Show (ArgType b), Arbitrary a, Integral a, Num b, Eq b, A.Integral a, A.Num b, A.FromIntegral a b) + => Backend + -> proxy a + -> proxy b + -> TestTree +testFromIntegral b ta tb = + testProperty (printf "%s->%s" (showType ta) (showType tb)) $ prop_fromIntegral b ta tb + +testMainAcc + :: ( Arbitrary a, Show (ArgType a) + , Ord a, Integral a, Bounded a, FiniteBits a + , A.Ord a, A.Integral a, A.Bounded a, A.FiniteBits a + ) + => Backend + -> proxy a + -> TestTree +testMainAcc b t = testGroup (showType t) + [ testGroup "Eq" + [ testProperty "(==)" $ prop_eq' b t + , testProperty "(/=)" $ prop_neq' b t + ] + , testGroup "Ord" + [ testProperty "(<)" $ prop_lt' b t + , testProperty "(>)" $ prop_gt' b t + , testProperty "(<=)" $ prop_lte' b t + , testProperty "(>=)" $ prop_gte' b t + ] + , testGroup "Bounded" + [ testProperty "minBound" $ prop_minBound' b t + , testProperty "maxBound" $ prop_maxBound' b t + ] + , testGroup "Num" + [ testProperty "negate" $ prop_negate' b t + , testProperty "abs" $ prop_abs' b t + , testProperty "signum" $ prop_signum' b t + , testProperty "(+)" $ prop_add' b t + , testProperty "(-)" $ prop_sub' b t + , testProperty "(*)" $ prop_mul' b t + , testProperty "fromInteger" $ prop_fromInteger' b t + ] + , testGroup "Integral" + [ testProperty "quot" $ prop_quot' b t + , testProperty "rem" $ prop_rem' b t + , testProperty "quotRem" $ prop_quotRem' b t + , testProperty "div" $ prop_div' b t + , testProperty "mod" $ prop_mod' b t + , testProperty "divMod" $ prop_divMod' b t + ] + , testGroup "Bits" + [ testProperty "complement" $ prop_complement' b t + , testProperty "xor" $ prop_xor' b t + , testProperty "(.&.)" $ prop_band' b t + , testProperty "(.|.)" $ prop_bor' b t + , testProperty "shiftL" $ prop_shiftL' b t + , testProperty "shiftR" $ prop_shiftR' b t + , testProperty "shift" $ prop_shift' b t + , testProperty "rotateL" $ prop_rotateL' b t + , testProperty "rotateR" $ prop_rotateR' b t + , testProperty "rotate" $ prop_rotate' b t + , testProperty "bit" $ prop_bit' b t + , testProperty "testBit" $ prop_testBit' b t + , testProperty "setBit" $ prop_setBit' b t + , testProperty "clearBit" $ prop_clearBit' b t + , testProperty "complementBit" $ prop_complementBit' b t + , testProperty "popCount" $ prop_popCount' b t + ] + , testGroup "FiniteBits" + [ testProperty "countLeadingZeros" $ prop_clz' b t + , testProperty "countTrailingZeros" $ prop_ctz' b t + ] + ] + + +prop_addWithCarry, prop_mulWithCarry :: (Num2 a, Integral a, FiniteBits (Unsigned a), Integral (Unsigned a)) => proxy a -> Large a -> Large a -> Bool +prop_addWithCarry _ (Large x) (Large y) = uncurry toInteger2 (addWithCarry x y) == toInteger x + toInteger y +prop_mulWithCarry _ (Large x) (Large y) = uncurry toInteger2 (mulWithCarry x y) == toInteger x * toInteger y + +toInteger2 :: (Integral a, Integral b, FiniteBits b) => a -> b -> Integer +toInteger2 h l = toInteger h * 2 ^ finiteBitSize l + toInteger l + +prop_iso :: (Iso a b, Eq a) => proxy b -> a -> Bool +prop_iso t x = isoL (toIso t x) == x + +prop_eq, prop_neq :: (Iso a b, Eq a, Eq b) => proxy b -> a -> a -> Bool +prop_eq = prop_binary' (==) (==) +prop_neq = prop_binary' (/=) (/=) + +prop_compare :: (Iso a b, Ord a, Ord b) => proxy b -> a -> a -> Bool +prop_compare = prop_binary' compare compare + +prop_minBound, prop_maxBound :: (Iso a b, Bounded a, Bounded b, Eq a) => proxy b -> Bool +prop_minBound t = minBound == fromIso t minBound +prop_maxBound t = maxBound == fromIso t maxBound + +prop_succ, prop_pred :: (Bounded a, Enum a, Enum b, Eq a, Iso a b) => proxy b -> a -> Property +prop_succ t x = (x /= maxBound) ==> (succ x == with_unary t succ x) +prop_pred t x = (x /= minBound) ==> (pred x == with_unary t pred x) + +prop_negate, prop_abs, prop_signum :: (Iso a b, Num a, Num b, Eq a) => proxy b -> a -> Bool +prop_negate = prop_unary negate negate +prop_abs = prop_unary abs abs +prop_signum = prop_unary signum signum + +prop_add, prop_sub, prop_mul :: (Iso a b, Num a, Num b, Eq a) => proxy b -> a -> a -> Bool +prop_add = prop_binary (+) (+) +prop_sub = prop_binary (-) (-) +prop_mul = prop_binary (*) (*) + +prop_fromInteger :: (Iso a b, Num a, Eq a, Num b) => proxy b -> Integer -> Bool +prop_fromInteger t x = fromInteger x == fromIso t (fromInteger x) + +prop_toRational :: (Iso a b, Real a, Real b) => proxy b -> a -> Bool +prop_toRational = prop_unary' toRational toRational + +prop_toInteger :: (Iso a b, Integral a, Integral b) => proxy b -> a -> Bool +prop_toInteger = prop_unary' toInteger toInteger + +prop_quot, prop_rem, prop_div, prop_mod :: (Iso a b, Integral a, Integral b) => proxy b -> a -> NonZero a -> Bool +prop_quot t x (NonZero y) = prop_binary quot quot t x y +prop_rem t x (NonZero y) = prop_binary rem rem t x y +prop_div t x (NonZero y) = prop_binary div div t x y +prop_mod t x (NonZero y) = prop_binary mod mod t x y + +prop_quotRem :: (Iso a b, Integral a, Integral b) => proxy b -> a -> NonZero a -> Bool +prop_quotRem t x (NonZero y) = + let qr = quotRem x y + (q,r) = quotRem (toIso t x) (toIso t y) + in + qr == (fromIso t q, fromIso t r) + +prop_divMod :: (Iso a b, Integral a, Integral b) => proxy b -> a -> NonZero a -> Bool +prop_divMod t x (NonZero y) = + let qr = divMod x y + (q,r) = divMod (toIso t x) (toIso t y) + in + qr == (fromIso t q, fromIso t r) + +prop_complement :: (Iso a b, Bits a, Bits b) => proxy b -> a -> Bool +prop_complement = prop_unary complement complement + +prop_xor, prop_band, prop_bor :: (Iso a b, Bits a, Bits b) => proxy b -> a -> a -> Bool +prop_xor = prop_binary xor xor +prop_band = prop_binary (.&.) (.&.) +prop_bor = prop_binary (.|.) (.|.) + +prop_shiftL, prop_shiftR, prop_rotateL, prop_rotateR :: (Iso a b, FiniteBits a, FiniteBits b) => proxy b -> a -> NonNegative Int -> Property +prop_shiftL t x (NonNegative n) = n < finiteBitSize x ==> prop_unary (`shiftL` n) (`shiftL` n) t x +prop_shiftR t x (NonNegative n) = n < finiteBitSize x ==> prop_unary (`shiftR` n) (`shiftR` n) t x +prop_rotateL t x (NonNegative n) = n < finiteBitSize x ==> prop_unary (`rotateL` n) (`rotateL` n) t x +prop_rotateR t x (NonNegative n) = n < finiteBitSize x ==> prop_unary (`rotateR` n) (`rotateR` n) t x + +prop_shift, prop_rotate :: (Iso a b, FiniteBits a, FiniteBits b) => proxy b -> a -> Int -> Property +prop_shift t x n = abs n < finiteBitSize x ==> prop_unary (`shift` n) (`shift` n) t x +prop_rotate t x n = abs n < finiteBitSize x ==> prop_unary (`rotate` n) (`rotate` n) t x + +prop_bit :: forall proxy a b. (Iso a b, FiniteBits a, FiniteBits b) => proxy b -> Bool +prop_bit t = all (\b -> bit b == fromIso t (bit b)) [0 .. finiteBitSize (undefined::a) - 1] + +prop_testBit, prop_setBit, prop_clearBit, prop_complementBit :: (Iso a b, FiniteBits a, FiniteBits b) => proxy b -> a -> NonNegative Int -> Property +prop_testBit t x (NonNegative n) = n < finiteBitSize x ==> prop_unary' (`testBit` n) (`testBit` n) t x +prop_setBit t x (NonNegative n) = n < finiteBitSize x ==> prop_unary (`setBit` n) (`setBit` n) t x +prop_clearBit t x (NonNegative n) = n < finiteBitSize x ==> prop_unary (`clearBit` n) (`clearBit` n) t x +prop_complementBit t x (NonNegative n) = n < finiteBitSize x ==> prop_unary (`complementBit` n) (`complementBit` n) t x + +prop_popCount :: (Iso a b, FiniteBits a, FiniteBits b) => proxy b -> a -> Bool +prop_popCount = prop_unary' popCount popCount + +prop_clz, prop_ctz :: (Iso a b, FiniteBits a, FiniteBits b) => proxy b -> a -> Bool +prop_clz = prop_unary' countLeadingZeros countLeadingZeros +prop_ctz = prop_unary' countTrailingZeros countTrailingZeros + + +fromIso :: Iso a b => proxy b -> b -> a +fromIso _ = isoL + +toIso :: Iso a b => proxy b -> a -> b +toIso _ = isoR + +with_unary :: Iso a b => proxy b -> (b -> b) -> a -> a +with_unary _ f = isoL . f . isoR + +with_unary' :: Iso a b => proxy b -> (b -> r) -> a -> r +with_unary' _ f x = f (isoR x) + +prop_unary :: (Iso a b, Eq a) => (a -> a) -> (b -> b) -> proxy b -> a -> Bool +prop_unary f g p x = f x == with_unary p g x + +prop_unary' :: (Iso a b, Eq r) => (a -> r) -> (b -> r) -> proxy b -> a -> Bool +prop_unary' f g p x = f x == with_unary' p g x + +prop_binary :: (Iso a b, Eq a) => (a -> a -> a) -> (b -> b -> b) -> proxy b -> a -> a -> Bool +prop_binary f g p x y = f x y == with_binary p g x y + +with_binary :: Iso a b => proxy b -> (b -> b -> b) -> a -> a -> a +with_binary _ f x y = isoL $ f (isoR x) (isoR y) + +with_binary' :: Iso a b => proxy b -> (b -> b -> r) -> a -> a -> r +with_binary' _ f x y = f (isoR x) (isoR y) + +prop_binary' :: (Iso a b, Eq r) => (a -> a -> r) -> (b -> b -> r) -> proxy b -> a -> a -> Bool +prop_binary' f g p x y = f x y == with_binary' p g x y + + +type I64 = BigInt Int32 Word32 +type U64 = BigWord Word32 Word32 + +type II64 = BigInt Int16 (BigWord Word16 Word32) +type UU64 = BigWord Word16 (BigWord Word16 Word32) + +class Iso a b | b -> a where + isoR :: a -> b + isoL :: b -> a + +instance Iso Word64 U64 where + isoR w = W2 (fromIntegral (w `shiftR` 32)) (fromIntegral w) + isoL (W2 h l) = fromIntegral h `shiftL` 32 .|. fromIntegral l + +instance Iso Word64 UU64 where + isoR w = W2 (fromIntegral (w `shiftR` 48)) (W2 (fromIntegral (w `shiftR` 32)) (fromIntegral w)) + isoL (W2 h (W2 lh ll)) = fromIntegral h `shiftL` 48 + .|. fromIntegral lh `shiftL` 32 + .|. fromIntegral ll + +instance Iso Int64 I64 where + isoR w = I2 (fromIntegral (w `shiftR` 32)) (fromIntegral w) + isoL (I2 h l) = fromIntegral h `shiftL` 32 .|. fromIntegral l + +instance Iso Int64 II64 where + isoR w = I2 (fromIntegral (w `shiftR` 48)) (W2 (fromIntegral (w `shiftR` 32)) (fromIntegral w)) + isoL (I2 h (W2 lh ll)) = fromIntegral h `shiftL` 48 + .|. fromIntegral lh `shiftL` 32 + .|. fromIntegral ll + +instance Elt a => Iso a (Scalar a) where + isoR x = A.fromList A.Z [x] + isoL x = A.indexArray x A.Z + +instance (Arbitrary a, Arbitrary b) => Arbitrary (BigWord a b) where + arbitrary = W2 <$> arbitrary <*> arbitrary + shrink (W2 hi lo) = [ W2 hi' lo' | (hi',lo') <- shrink (hi,lo) ] + +instance (Arbitrary a, Arbitrary b) => Arbitrary (BigInt a b) where + arbitrary = I2 <$> arbitrary <*> arbitrary + shrink (I2 hi lo) = [ I2 hi' lo' | (hi',lo') <- shrink (hi,lo) ] + + +{-# INLINE prop_unary_acc #-} +prop_unary_acc :: (Elt a, Elt r, Eq r) => (a -> r) -> (Exp a -> Exp r) -> Backend -> proxy a -> a -> Bool +prop_unary_acc f g b p x = f x == with_unary_acc b p g x + +{-# INLINE prop_binary_acc #-} +prop_binary_acc :: (Elt a, Elt r, Eq r) => (a -> a -> r) -> (Exp a -> Exp a -> Exp r) -> Backend -> proxy a -> a -> a -> Bool +prop_binary_acc f g b p x y = f x y == with_binary_acc b p g x y + +{-# INLINE prop_binary_acc' #-} +prop_binary_acc' :: (Elt a, Elt r, Eq r) => (a -> Int -> r) -> (Exp a -> Exp Int -> Exp r) -> Backend -> proxy a -> a -> Int -> Bool +prop_binary_acc' f g b p x y = f x y == with_binary_acc' b p g x y + +-- TLM: make sure to pass the operation though a 'run', otherwise the expression +-- will be constant-folded away before hitting the backend. +-- +{-# INLINE with_unary_acc #-} +with_unary_acc :: forall proxy a r. (Elt a, Elt r) => Backend -> proxy a -> (Exp a -> Exp r) -> a -> r +with_unary_acc b _ f = isoL . go . isoR + where + go :: Scalar a -> Scalar r + !go = run1 b (A.map f) + +{-# INLINE with_binary_acc #-} +with_binary_acc :: forall proxy a r. (Elt a, Elt r) => Backend -> proxy a -> (Exp a -> Exp a -> Exp r) -> a -> a -> r +with_binary_acc b _ f x y = isoL $ go (isoR x) (isoR y) + where + go :: Scalar a -> Scalar a -> Scalar r + !go = run2 b (A.zipWith f) + +{-# INLINE with_binary_acc' #-} +with_binary_acc' :: forall proxy a r. (Elt a, Elt r) => Backend -> proxy a -> (Exp a -> Exp Int -> Exp r) -> a -> Int -> r +with_binary_acc' b _ f x y = isoL $ go (isoR x) (isoR y) + where + go :: Scalar a -> Scalar Int -> Scalar r + !go = run2 b (A.zipWith f) + +data Backend = Interpreter +#ifdef ACCELERATE_LLVM_NATIVE_BACKEND + | Native +#endif +#ifdef ACCELERATE_LLVM_PTX_BACKEND + | PTX +#endif + +instance Show Backend where + show Interpreter = "interpreter" +#ifdef ACCELERATE_LLVM_NATIVE_BACKEND + show Native = "llvm-cpu" +#endif +#ifdef ACCELERATE_LLVM_PTX_BACKEND + show PTX = "llvm-ptx" +#endif + +{-# INLINE run #-} +run :: Arrays a => Backend -> Acc a -> a +run Interpreter = I.run +#ifdef ACCELERATE_LLVM_NATIVE_BACKEND +run Native = CPU.run +#endif +#ifdef ACCELERATE_LLVM_PTX_BACKEND +run PTX = PTX.run +#endif + + +{-# INLINE run1 #-} +run1 :: (Arrays a, Arrays b) => Backend -> (Acc a -> Acc b) -> a -> b +run1 Interpreter f = I.run1 f +#ifdef ACCELERATE_LLVM_NATIVE_BACKEND +run1 Native f = CPU.run1 f +#endif +#ifdef ACCELERATE_LLVM_PTX_BACKEND +run1 PTX f = PTX.run1 f +#endif + +{-# INLINE run2 #-} +run2 :: (Arrays a, Arrays b, Arrays c) => Backend -> (Acc a -> Acc b -> Acc c) -> a -> b -> c +run2 b f x y = go (x,y) + where + !go = run1 b (A.uncurry f) + +infixr 0 $$ +($$) :: (b -> a) -> (c -> d -> b) -> c -> d -> a +(f $$ g) x y = f (g x y) + + +{-# INLINE prop_addWithCarry' #-} +{-# INLINE prop_mulWithCarry' #-} +prop_addWithCarry', prop_mulWithCarry' + :: (Num2 (Exp a), Elt a, Elt (Unsigned a), Integral a, Integral (Unsigned a), FiniteBits (Unsigned a), A.Lift Exp (Unsigned (Exp a)), Plain (Unsigned (Exp a)) ~ Unsigned a) + => Backend + -> proxy a + -> Large a + -> Large a + -> Bool +prop_addWithCarry' b t (Large x) (Large y) = uncurry toInteger2 (with_binary_acc b t (A.lift $$ addWithCarry) x y) == toInteger x + toInteger y +prop_mulWithCarry' b t (Large x) (Large y) = uncurry toInteger2 (with_binary_acc b t (A.lift $$ mulWithCarry) x y) == toInteger x * toInteger y + +{-# INLINE prop_fromIntegral #-} +prop_fromIntegral + :: forall proxy a b. (Integral a, Num b, Eq b, A.Integral a, A.Num b, A.FromIntegral a b) + => Backend + -> proxy a + -> proxy b + -> a + -> Bool +prop_fromIntegral b a _ = prop_unary_acc fromIntegral (A.fromIntegral :: Exp a -> Exp b) b a + +{-# INLINE prop_eq' #-} +{-# INLINE prop_neq' #-} +prop_eq', prop_neq' :: (Eq a, A.Eq a) => Backend -> proxy a -> a -> a -> Bool +prop_eq' = prop_binary_acc (==) (A.==) +prop_neq' = prop_binary_acc (/=) (A./=) + +{-# INLINE prop_lt' #-} +{-# INLINE prop_gt' #-} +{-# INLINE prop_lte' #-} +{-# INLINE prop_gte' #-} +prop_lt', prop_lte', prop_gt', prop_gte' :: (Ord a, A.Ord a) => Backend -> proxy a -> a -> a -> Bool +prop_lt' = prop_binary_acc (<) (A.<) +prop_gt' = prop_binary_acc (>) (A.>) +prop_lte' = prop_binary_acc (<=) (A.<=) +prop_gte' = prop_binary_acc (>=) (A.>=) + +{-# INLINE prop_minBound' #-} +{-# INLINE prop_maxBound' #-} +prop_minBound', prop_maxBound' :: forall proxy a. (Bounded a, Eq a, A.Bounded a) => Backend -> proxy a -> Bool +prop_minBound' b _ = minBound == isoL (run b (A.unit (minBound :: Exp a))) +prop_maxBound' b _ = maxBound == isoL (run b (A.unit (maxBound :: Exp a))) + +{-# INLINE prop_negate' #-} +{-# INLINE prop_abs' #-} +{-# INLINE prop_signum' #-} +prop_negate', prop_abs', prop_signum' :: (Num a, A.Num a, Eq a) => Backend -> proxy a -> a -> Bool +prop_negate' = prop_unary_acc negate negate +prop_abs' = prop_unary_acc abs abs +prop_signum' = prop_unary_acc signum signum + +{-# INLINE prop_add' #-} +{-# INLINE prop_sub' #-} +{-# INLINE prop_mul' #-} +prop_add', prop_sub', prop_mul' :: (Num a, A.Num a, Eq a) => Backend -> proxy a -> a -> a -> Bool +prop_add' = prop_binary_acc (+) (+) +prop_sub' = prop_binary_acc (-) (-) +prop_mul' = prop_binary_acc (*) (*) + +{-# INLINE prop_fromInteger' #-} +prop_fromInteger' :: forall proxy a. (Num a, Eq a, A.Num a) => Backend -> proxy a -> Integer -> Bool +prop_fromInteger' b _ x = fromInteger x == isoL (run b (A.unit (fromInteger x :: Exp a))) + +{-# INLINE prop_quot' #-} +{-# INLINE prop_rem' #-} +{-# INLINE prop_div' #-} +{-# INLINE prop_mod' #-} +{-# INLINE prop_quotRem' #-} +{-# INLINE prop_divMod' #-} +prop_quot', prop_rem', prop_div', prop_mod', prop_quotRem', prop_divMod' :: (Integral a, A.Integral a) => Backend -> proxy a -> a -> NonZero a -> Bool +prop_quot' b t x (NonZero y) = prop_binary_acc quot quot b t x y +prop_rem' b t x (NonZero y) = prop_binary_acc rem rem b t x y +prop_div' b t x (NonZero y) = prop_binary_acc div div b t x y +prop_mod' b t x (NonZero y) = prop_binary_acc mod mod b t x y +prop_quotRem' b t x (NonZero y) = prop_binary_acc quotRem (A.lift $$ quotRem) b t x y +prop_divMod' b t x (NonZero y) = prop_binary_acc divMod (A.lift $$ divMod) b t x y + +{-# INLINE prop_complement' #-} +prop_complement' :: (Bits a, A.Bits a) => Backend -> proxy a -> a -> Bool +prop_complement' = prop_unary_acc complement A.complement + +{-# INLINE prop_xor' #-} +{-# INLINE prop_band' #-} +{-# INLINE prop_bor' #-} +prop_xor', prop_band', prop_bor' :: (Bits a, A.Bits a) => Backend -> proxy a -> a -> a -> Bool +prop_xor' = prop_binary_acc xor A.xor +prop_band' = prop_binary_acc (.&.) (A..&.) +prop_bor' = prop_binary_acc (.|.) (A..|.) + +{-# INLINE prop_shiftL' #-} +{-# INLINE prop_shiftR' #-} +{-# INLINE prop_rotateL' #-} +{-# INLINE prop_rotateR' #-} +prop_shiftL', prop_shiftR', prop_rotateL', prop_rotateR' :: (FiniteBits a, A.FiniteBits a) => Backend -> proxy a -> a -> NonNegative Int -> Property +prop_shiftL' b t x (NonNegative n) = n < finiteBitSize x ==> prop_binary_acc' shiftL A.shiftL b t x n +prop_shiftR' b t x (NonNegative n) = n < finiteBitSize x ==> prop_binary_acc' shiftR A.shiftR b t x n +prop_rotateL' b t x (NonNegative n) = n < finiteBitSize x ==> prop_binary_acc' rotateL A.rotateL b t x n +prop_rotateR' b t x (NonNegative n) = n < finiteBitSize x ==> prop_binary_acc' rotateR A.rotateR b t x n + +{-# INLINE prop_shift' #-} +{-# INLINE prop_rotate' #-} +prop_shift', prop_rotate' :: (FiniteBits a, A.FiniteBits a) => Backend -> proxy a -> a -> Int -> Property +prop_shift' b t x n = abs n < finiteBitSize x ==> prop_binary_acc' shift A.shift b t x n +prop_rotate' b t x n = abs n < finiteBitSize x ==> prop_binary_acc' rotate A.rotate b t x n + +prop_bit' :: forall proxy a. (FiniteBits a, A.FiniteBits a) => Backend -> proxy a -> Bool +prop_bit' b _ = all (prop_unary_acc (bit :: Int -> a) A.bit b Proxy) [0 .. finiteBitSize (undefined::a) - 1] + +{-# INLINE prop_testBit' #-} +{-# INLINE prop_setBit' #-} +{-# INLINE prop_clearBit' #-} +{-# INLINE prop_complementBit' #-} +prop_testBit', prop_setBit', prop_clearBit', prop_complementBit' :: (FiniteBits a, A.FiniteBits a) => Backend -> proxy a -> a -> NonNegative Int -> Property +prop_testBit' b t x (NonNegative n) = n < finiteBitSize x ==> prop_binary_acc' testBit A.testBit b t x +prop_setBit' b t x (NonNegative n) = n < finiteBitSize x ==> prop_binary_acc' setBit A.setBit b t x +prop_clearBit' b t x (NonNegative n) = n < finiteBitSize x ==> prop_binary_acc' clearBit A.clearBit b t x +prop_complementBit' b t x (NonNegative n) = n < finiteBitSize x ==> prop_binary_acc' complementBit A.complementBit b t x + +{-# INLINE prop_popCount' #-} +prop_popCount' :: (FiniteBits a, A.FiniteBits a) => Backend -> proxy a -> a -> Bool +prop_popCount' = prop_unary_acc popCount A.popCount + +{-# INLINE prop_clz' #-} +{-# INLINE prop_ctz' #-} +prop_clz', prop_ctz' :: (FiniteBits a, A.FiniteBits a) => Backend -> proxy a -> a -> Bool +prop_clz' = prop_unary_acc countLeadingZeros A.countLeadingZeros +prop_ctz' = prop_unary_acc countTrailingZeros A.countTrailingZeros + + +data ArgType (a :: *) = AT + +showType :: forall proxy a. Show (ArgType a) => proxy a -> String +showType _ = show (AT :: ArgType a) + +instance FiniteBits (BigWord a b) => Show (ArgType (BigWord a b)) where + show _ = printf "Word%d" (finiteBitSize (undefined::BigWord a b)) + +instance FiniteBits (BigInt a b) => Show (ArgType (BigInt a b)) where + show _ = printf "Int%d" (finiteBitSize (undefined::BigInt a b)) + +instance Show (ArgType Int8) where show _ = "Int8" +instance Show (ArgType Int16) where show _ = "Int16" +instance Show (ArgType Int32) where show _ = "Int32" +instance Show (ArgType Int64) where show _ = "Int64" +instance Show (ArgType Word8) where show _ = "Word8" +instance Show (ArgType Word16) where show _ = "Word16" +instance Show (ArgType Word32) where show _ = "Word32" +instance Show (ArgType Word64) where show _ = "Word64" +