accelerate-bignum (empty) → 0.1.0.0
raw patch · 20 files changed
+3965/−0 lines, 20 filesdep +acceleratedep +accelerate-bignumdep +accelerate-iosetup-changed
Dependencies added: accelerate, accelerate-bignum, accelerate-io, accelerate-llvm, accelerate-llvm-native, accelerate-llvm-ptx, base, criterion, ghc-prim, llvm-hs-pure, mwc-random, tasty, tasty-quickcheck, template-haskell, vector, vector-th-unbox, wide-word
Files
- LICENSE +30/−0
- README.md +11/−0
- Setup.hs +2/−0
- accelerate-bignum.cabal +175/−0
- bench/Accelerate.hs +154/−0
- bench/Main.hs +52/−0
- bench/WideWord.hs +110/−0
- src/Data/Array/Accelerate/Data/BigInt.hs +32/−0
- src/Data/Array/Accelerate/Data/BigWord.hs +31/−0
- src/Data/Array/Accelerate/Internal/BigInt.hs +319/−0
- src/Data/Array/Accelerate/Internal/BigInt.hs-boot +18/−0
- src/Data/Array/Accelerate/Internal/BigWord.hs +372/−0
- src/Data/Array/Accelerate/Internal/LLVM/Native.hs +238/−0
- src/Data/Array/Accelerate/Internal/LLVM/PTX.hs +238/−0
- src/Data/Array/Accelerate/Internal/LLVM/Prim.hs +256/−0
- src/Data/Array/Accelerate/Internal/Num2.hs +177/−0
- src/Data/Array/Accelerate/Internal/Orphans.hs +16/−0
- src/Data/Array/Accelerate/Internal/Orphans/Base.hs +953/−0
- src/Data/Array/Accelerate/Internal/Orphans/Elt.hs +83/−0
- test/Main.hs +698/−0
+ LICENSE view
@@ -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.
+ README.md view
@@ -0,0 +1,11 @@+Big-number arithmetic for Accelerate+====================================++[](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).+
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ accelerate-bignum.cabal view
@@ -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:+ <http://hackage.haskell.org/package/accelerate>++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 <tmcdonell@cse.unsw.edu.au>+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+
+ bench/Accelerate.hs view
@@ -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))+
+ bench/Main.hs view
@@ -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+ ]+ ]+
+ bench/WideWord.hs view
@@ -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+ ]+ ]+
+ src/Data/Array/Accelerate/Data/BigInt.hs view
@@ -0,0 +1,32 @@+-- |+-- Module : Data.Array.Accelerate.Data.BigInt+-- Copyright : [2016] Trevor L. McDonell+-- License : BSD3+--+-- Maintainer : Trevor L. McDonell <tmcdonell@cse.unsw.edu.au>+-- 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 ()+
+ src/Data/Array/Accelerate/Data/BigWord.hs view
@@ -0,0 +1,31 @@+-- |+-- Module : Data.Array.Accelerate.Data.BigWord+-- Copyright : [2016] Trevor L. McDonell+-- License : BSD3+--+-- Maintainer : Trevor L. McDonell <tmcdonell@cse.unsw.edu.au>+-- 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 ()+
+ src/Data/Array/Accelerate/Internal/BigInt.hs view
@@ -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 <tmcdonell@cse.unsw.edu.au>+-- 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+
+ src/Data/Array/Accelerate/Internal/BigInt.hs-boot view
@@ -0,0 +1,18 @@+-- |+-- Module : Data.Array.Accelerate.Internal.BigInt-boot+-- Copyright : [2016] Trevor L. McDonell+-- License : BSD3+--+-- Maintainer : Trevor L. McDonell <tmcdonell@cse.unsw.edu.au>+-- 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+
+ src/Data/Array/Accelerate/Internal/BigWord.hs view
@@ -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 <tmcdonell@cse.unsw.edu.au>+-- 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)+
+ src/Data/Array/Accelerate/Internal/LLVM/Native.hs view
@@ -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 <tmcdonell@cse.unsw.edu.au>+-- 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+
+ src/Data/Array/Accelerate/Internal/LLVM/PTX.hs view
@@ -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 <tmcdonell@cse.unsw.edu.au>+-- 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+
+ src/Data/Array/Accelerate/Internal/LLVM/Prim.hs view
@@ -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 <tmcdonell@cse.unsw.edu.au>+-- 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)+
+ src/Data/Array/Accelerate/Internal/Num2.hs view
@@ -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 <tmcdonell@cse.unsw.edu.au>+-- 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))+
+ src/Data/Array/Accelerate/Internal/Orphans.hs view
@@ -0,0 +1,16 @@+-- |+-- Module : Data.Array.Accelerate.Internal.Orphans+-- Copyright : [2016] Trevor L. McDonell+-- License : BSD3+--+-- Maintainer : Trevor L. McDonell <tmcdonell@cse.unsw.edu.au>+-- 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 ()+
+ src/Data/Array/Accelerate/Internal/Orphans/Base.hs view
@@ -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 <tmcdonell@cse.unsw.edu.au>+-- 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)+ )+
+ src/Data/Array/Accelerate/Internal/Orphans/Elt.hs view
@@ -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 <tmcdonell@cse.unsw.edu.au>+-- 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+
+ test/Main.hs view
@@ -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"+