diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -7,14 +7,22 @@ (PVP)](https://pvp.haskell.org) +## [0.3.0.0] - 2020-08-26 +### Changed + * update for accelerate-1.3 + * support LLVM-9 + ## [0.2.0.0] - 2018-04-03 - * update for accelerate-1.2 - * support LLVM-6.0 +### Changed + * update for accelerate-1.2 + * support LLVM-6.0 ## [0.1.0.0] - 2017-03-31 - * initial release +### New + * initial release +[0.3.0.0]: https://github.com/tmcdonell/accelerate-bignum/compare/0.2.0.0...v0.3.0.0 [0.2.0.0]: https://github.com/tmcdonell/accelerate-bignum/compare/0.1.0.0...0.2.0.0 [0.1.0.0]: https://github.com/tmcdonell/accelerate-bignum/compare/e290717323f3e7c56064e3c848d1ea9d6ac1a8f5...HEAD diff --git a/LICENSE b/LICENSE --- a/LICENSE +++ b/LICENSE @@ -1,4 +1,4 @@ -Copyright Trevor L. McDonell (c) 2017 +Copyright Trevor L. McDonell (c) [2016..2020] All rights reserved. diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -1,12 +1,24 @@ -Big-number arithmetic for Accelerate -==================================== +
+henlo, my name is Theia -[![Build Status](https://travis-ci.org/tmcdonell/accelerate-bignum.svg)](https://travis-ci.org/tmcdonell/accelerate-bignum) +# Big-number arithmetic + +[![GitHub CI](https://github.com/tmcdonell/accelerate-bignum/workflows/CI/badge.svg)](https://github.com/tmcdonell/accelerate-bignum/actions) +[![Gitter](https://img.shields.io/gitter/room/nwjs/nw.js.svg)](https://gitter.im/AccelerateHS/Lobby) +
+[![Stackage LTS](https://stackage.org/package/accelerate-bignum/badge/lts)](https://stackage.org/lts/package/accelerate-bignum) +[![Stackage Nightly](https://stackage.org/package/accelerate-bignum/badge/nightly)](https://stackage.org/nightly/package/accelerate-bignum) [![Hackage](https://img.shields.io/hackage/v/accelerate-bignum.svg)](https://hackage.haskell.org/package/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 +for [Accelerate][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). +Contributions and bug reports are welcome!
+Please feel free to contact me through [GitHub][accelerate] or [gitter.im][gitter.im]. + + [accelerate]: https://github.com/AccelerateHS/accelerate + [gitter.im]: https://gitter.im/AccelerateHS/Lobby diff --git a/accelerate-bignum.cabal b/accelerate-bignum.cabal --- a/accelerate-bignum.cabal +++ b/accelerate-bignum.cabal @@ -1,5 +1,5 @@ name: accelerate-bignum -version: 0.2.0.0 +version: 0.3.0.0 synopsis: Fixed-length large integer arithmetic for Accelerate description: This package provides fixed-length large integer types and arithmetic @@ -14,9 +14,9 @@ license: BSD3 license-file: LICENSE author: Trevor L. McDonell -maintainer: Trevor L. McDonell +maintainer: Trevor L. McDonell copyright: BSD3 -category: Compilers/Interpreters, Concurrency, Data, Parallelism +category: Accelerate, Data build-type: Simple cabal-version: >= 1.10 @@ -50,16 +50,16 @@ Data.Array.Accelerate.Internal.Orphans.Elt build-depends: - base >= 4.8 && < 4.12 - , accelerate >= 1.0 + base >= 4.8 && < 5 + , accelerate >= 1.3 , ghc-prim , template-haskell if flag(llvm-cpu) cpp-options: -DACCELERATE_LLVM_NATIVE_BACKEND build-depends: - accelerate-llvm >= 1.0 - , accelerate-llvm-native >= 1.0 + accelerate-llvm >= 1.3 + , accelerate-llvm-native >= 1.3 , llvm-hs-pure >= 3.9 -- other-modules: @@ -68,8 +68,8 @@ if flag(llvm-ptx) cpp-options: -DACCELERATE_LLVM_PTX_BACKEND build-depends: - accelerate-llvm >= 1.0 - , accelerate-llvm-ptx >= 1.0 + accelerate-llvm >= 1.3 + , accelerate-llvm-ptx >= 1.3 , llvm-hs-pure >= 3.9 -- other-modules: @@ -100,7 +100,7 @@ buildable: False build-depends: - base >= 4.7 && < 4.12 + base >= 4.7 && < 5 , accelerate , accelerate-bignum , accelerate-llvm-native @@ -144,7 +144,7 @@ buildable: False build-depends: - base >= 4.7 && < 4.12 + base >= 4.7 && < 5 , accelerate , accelerate-bignum , accelerate-llvm-ptx @@ -187,10 +187,10 @@ WideWord build-depends: - base >= 4.8 && < 4.12 + base >= 4.8 && < 5 , accelerate , accelerate-bignum - , accelerate-io >= 0.16 + , accelerate-io-vector >= 0.1 , criterion >= 1.0 , mwc-random >= 0.13 , vector >= 0.11 @@ -225,8 +225,7 @@ source-repository this type: git - tag: 0.2.0.0 + tag: v0.3.0.0 location: https://github.com/tmcdonell/accelerate-bignum -- vim: nospell - diff --git a/bench/Accelerate.hs b/bench/Accelerate.hs --- a/bench/Accelerate.hs +++ b/bench/Accelerate.hs @@ -1,5 +1,4 @@ {-# LANGUAGE BangPatterns #-} -{-# LANGUAGE CPP #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE PolyKinds #-} @@ -12,15 +11,11 @@ import Data.Array.Accelerate.Data.Bits as A import Data.Array.Accelerate.Data.BigWord import Data.Array.Accelerate.Data.BigInt -#if !MIN_VERSION_accelerate_io(1,2,0) -import Data.Array.Accelerate.IO -#else import Data.Array.Accelerate.IO.Data.Vector.Storable -#endif import Criterion.Main import Data.Proxy -import Prelude ( String, Show(..), undefined ) +import Prelude ( String, Show(..) ) import Text.Printf import qualified Data.Bits as P import qualified Data.Vector.Unboxed as U diff --git a/src/Data/Array/Accelerate/Data/BigInt.hs b/src/Data/Array/Accelerate/Data/BigInt.hs --- a/src/Data/Array/Accelerate/Data/BigInt.hs +++ b/src/Data/Array/Accelerate/Data/BigInt.hs @@ -1,9 +1,9 @@ -- | -- Module : Data.Array.Accelerate.Data.BigInt --- Copyright : [2016] Trevor L. McDonell +-- Copyright : [2016..2020] Trevor L. McDonell -- License : BSD3 -- --- Maintainer : Trevor L. McDonell +-- Maintainer : Trevor L. McDonell -- Stability : experimental -- Portability : non-portable (GHC extensions) -- diff --git a/src/Data/Array/Accelerate/Data/BigWord.hs b/src/Data/Array/Accelerate/Data/BigWord.hs --- a/src/Data/Array/Accelerate/Data/BigWord.hs +++ b/src/Data/Array/Accelerate/Data/BigWord.hs @@ -1,9 +1,9 @@ -- | -- Module : Data.Array.Accelerate.Data.BigWord --- Copyright : [2016] Trevor L. McDonell +-- Copyright : [2016..2020] Trevor L. McDonell -- License : BSD3 -- --- Maintainer : Trevor L. McDonell +-- Maintainer : Trevor L. McDonell -- Stability : experimental -- Portability : non-portable (GHC extensions) -- diff --git a/src/Data/Array/Accelerate/Internal/BigInt.hs b/src/Data/Array/Accelerate/Internal/BigInt.hs --- a/src/Data/Array/Accelerate/Internal/BigInt.hs +++ b/src/Data/Array/Accelerate/Internal/BigInt.hs @@ -1,14 +1,15 @@ {-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE UndecidableInstances #-} -- | -- Module : Data.Array.Accelerate.Internal.BigInt --- Copyright : [2016] Trevor L. McDonell +-- Copyright : [2016..2020] Trevor L. McDonell -- License : BSD3 -- --- Maintainer : Trevor L. McDonell +-- Maintainer : Trevor L. McDonell -- Stability : experimental -- Portability : non-portable (GHC extensions) -- @@ -38,6 +39,7 @@ import Data.Int import Data.Ratio import Data.Word +import GHC.Generics import Data.Array.Accelerate.Internal.BigWord import Data.Array.Accelerate.Internal.Num2 @@ -55,7 +57,7 @@ -- | Large integers of fixed size represented as separate (signed) high and -- (unsigned) low words. -- -data BigInt hi lo = I2 !hi !lo +data BigInt hi lo = I2 !hi !lo deriving Generic type BigIntCtx hi lo = (hi ~ Signed hi, lo ~ Unsigned lo, Signed (Unsigned hi) ~ hi) diff --git a/src/Data/Array/Accelerate/Internal/BigInt.hs-boot b/src/Data/Array/Accelerate/Internal/BigInt.hs-boot --- a/src/Data/Array/Accelerate/Internal/BigInt.hs-boot +++ b/src/Data/Array/Accelerate/Internal/BigInt.hs-boot @@ -3,7 +3,7 @@ -- Copyright : [2016] Trevor L. McDonell -- License : BSD3 -- --- Maintainer : Trevor L. McDonell +-- Maintainer : Trevor L. McDonell -- Stability : experimental -- Portability : non-portable (GHC extensions) -- diff --git a/src/Data/Array/Accelerate/Internal/BigWord.hs b/src/Data/Array/Accelerate/Internal/BigWord.hs --- a/src/Data/Array/Accelerate/Internal/BigWord.hs +++ b/src/Data/Array/Accelerate/Internal/BigWord.hs @@ -1,14 +1,15 @@ {-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE UndecidableInstances #-} -- | -- Module : Data.Array.Accelerate.Internal.BigWord --- Copyright : [2016] Trevor L. McDonell +-- Copyright : [2016..2020] Trevor L. McDonell -- License : BSD3 -- --- Maintainer : Trevor L. McDonell +-- Maintainer : Trevor L. McDonell -- Stability : experimental -- Portability : non-portable (GHC extensions) -- @@ -42,6 +43,7 @@ import Data.Bits import Data.Ratio import Data.Word +import GHC.Generics import {-# SOURCE #-} Data.Array.Accelerate.Internal.BigInt import Data.Array.Accelerate.Internal.Num2 @@ -59,7 +61,7 @@ -- | Large word of fixed size represented as separate high and low (unsigned) -- words. -- -data BigWord hi lo = W2 !hi !lo +data BigWord hi lo = W2 !hi !lo deriving Generic type BigWordCtx hi lo = (hi ~ Unsigned hi, lo ~ Unsigned lo) diff --git a/src/Data/Array/Accelerate/Internal/LLVM/Native.hs b/src/Data/Array/Accelerate/Internal/LLVM/Native.hs --- a/src/Data/Array/Accelerate/Internal/LLVM/Native.hs +++ b/src/Data/Array/Accelerate/Internal/LLVM/Native.hs @@ -2,10 +2,10 @@ {-# LANGUAGE MagicHash #-} -- | -- Module : Data.Array.Accelerate.Internal.LLVM.Native --- Copyright : [2016] Trevor L. McDonell +-- Copyright : [2016..2020] Trevor L. McDonell -- License : BSD3 -- --- Maintainer : Trevor L. McDonell +-- Maintainer : Trevor L. McDonell -- Stability : experimental -- Portability : non-portable (GHC extensions) -- @@ -27,6 +27,7 @@ ) where import Data.Array.Accelerate as A +import Data.Array.Accelerate.Sugar.Elt import Data.Array.Accelerate.Internal.BigInt import Data.Array.Accelerate.Internal.BigWord import Data.Array.Accelerate.Internal.Orphans.Elt () @@ -41,7 +42,7 @@ #ifdef ACCELERATE_LLVM_NATIVE_BACKEND wrap2 :: (Elt a, Elt b, Elt c) => String -- name of the operation - -> IRFun1 Native () ((a, b) -> c) -- foreign implementation + -> IRFun1 Native () (EltR (a, b) -> EltR c) -- foreign implementation -> (Exp a -> Exp b -> Exp c) -- fallback implementation -> Exp a -> Exp b diff --git a/src/Data/Array/Accelerate/Internal/LLVM/PTX.hs b/src/Data/Array/Accelerate/Internal/LLVM/PTX.hs --- a/src/Data/Array/Accelerate/Internal/LLVM/PTX.hs +++ b/src/Data/Array/Accelerate/Internal/LLVM/PTX.hs @@ -2,10 +2,10 @@ {-# LANGUAGE MagicHash #-} -- | -- Module : Data.Array.Accelerate.Internal.LLVM.PTX --- Copyright : [2016] Trevor L. McDonell +-- Copyright : [2016..2020] Trevor L. McDonell -- License : BSD3 -- --- Maintainer : Trevor L. McDonell +-- Maintainer : Trevor L. McDonell -- Stability : experimental -- Portability : non-portable (GHC extensions) -- @@ -27,6 +27,7 @@ ) where import Data.Array.Accelerate as A +import Data.Array.Accelerate.Sugar.Elt import Data.Array.Accelerate.Internal.BigInt import Data.Array.Accelerate.Internal.BigWord import Data.Array.Accelerate.Internal.Orphans.Elt () @@ -41,7 +42,7 @@ #ifdef ACCELERATE_LLVM_PTX_BACKEND wrap2 :: (Elt a, Elt b, Elt c) => String -- name of the operation - -> IRFun1 PTX () ((a, b) -> c) -- foreign implementation + -> IRFun1 PTX () (EltR (a, b) -> EltR c) -- foreign implementation -> (Exp a -> Exp b -> Exp c) -- fallback implementation -> Exp a -> Exp b diff --git a/src/Data/Array/Accelerate/Internal/LLVM/Prim.hs b/src/Data/Array/Accelerate/Internal/LLVM/Prim.hs --- a/src/Data/Array/Accelerate/Internal/LLVM/Prim.hs +++ b/src/Data/Array/Accelerate/Internal/LLVM/Prim.hs @@ -1,13 +1,12 @@ -{-# LANGUAGE CPP #-} -{-# LANGUAGE MagicHash #-} -{-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE CPP #-} +{-# LANGUAGE MagicHash #-} +{-# LANGUAGE TypeFamilies #-} -- | -- Module : Data.Array.Accelerate.Internal.LLVM.Prim --- Copyright : [2016] Trevor L. McDonell +-- Copyright : [2016..2020] Trevor L. McDonell -- License : BSD3 -- --- Maintainer : Trevor L. McDonell +-- Maintainer : Trevor L. McDonell -- Stability : experimental -- Portability : non-portable (GHC extensions) -- @@ -30,103 +29,119 @@ ) where -import Data.Int -import Data.Word - import Data.Array.Accelerate.Error +import Data.Array.Accelerate.Sugar.Elt 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.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 +#if MIN_VERSION_accelerate_llvm(1,3,0) +import LLVM.AST.Type.Downcast ( downcast ) +#else +import Data.Array.Accelerate.LLVM.CodeGen.Downcast ( downcast ) +#endif import LLVM.AST.Constant ( Constant(Int) ) import LLVM.AST.Instruction hiding ( nsw, nuw ) -import LLVM.AST.Name -import LLVM.AST.Operand +import LLVM.AST.Name ( Name(..) ) +import LLVM.AST.Operand ( Operand(..) ) import LLVM.AST.Type +import Data.Int +import Data.Word +import Prelude hiding ( uncurry ) + +uncurry :: (Operands a -> Operands b -> c) -> Operands (((), a), b) -> c +uncurry f (OP_Unit `OP_Pair` x `OP_Pair` y) = f x y + -- Primitive instruction wrappers -- ------------------------------ -- Operations from Num2 -- -------------------- -addWithCarryInt64# :: IRFun1 arch () ((Int64, Int64) -> (Int64, Word64)) -addWithCarryInt64# = IRFun1 $ A.uncurry (prim_wideningInt64 (Add nsw nuw)) +addWithCarryInt64# :: IRFun1 arch () (EltR (Int64, Int64) -> EltR (Int64, Word64)) +addWithCarryInt64# = IRFun1 $ uncurry (prim_wideningInt64 (Add nsw nuw)) -mulWithCarryInt64# :: IRFun1 arch () ((Int64, Int64) -> (Int64, Word64)) -mulWithCarryInt64# = IRFun1 $ A.uncurry (prim_wideningInt64 (Mul nsw nuw)) +mulWithCarryInt64# :: IRFun1 arch () (EltR (Int64, Int64) -> EltR (Int64, Word64)) +mulWithCarryInt64# = IRFun1 $ uncurry (prim_wideningInt64 (Mul nsw nuw)) -addWithCarryWord64# :: IRFun1 arch () ((Word64, Word64) -> (Word64, Word64)) -addWithCarryWord64# = IRFun1 $ A.uncurry (prim_wideningWord64 (Add nsw nuw)) +addWithCarryWord64# :: IRFun1 arch () (EltR (Word64, Word64) -> EltR (Word64, Word64)) +addWithCarryWord64# = IRFun1 $ uncurry (prim_wideningWord64 (Add nsw nuw)) -mulWithCarryWord64# :: IRFun1 arch () ((Word64, Word64) -> (Word64, Word64)) -mulWithCarryWord64# = IRFun1 $ A.uncurry (prim_wideningWord64 (Mul nsw nuw)) +mulWithCarryWord64# :: IRFun1 arch () (EltR (Word64, Word64) -> EltR (Word64, Word64)) +mulWithCarryWord64# = IRFun1 $ 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 +prim_wideningInt64 + :: (Operand -> Operand -> InstructionMetadata -> Instruction) + -> Operands Int64 + -> Operands Int64 + -> CodeGen arch (Operands (((), Int64), Word64)) +prim_wideningInt64 op (OP_Int64 x) (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)) + return $ OP_Unit `OP_Pair` upcastInt64 d `OP_Pair` 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 +prim_wideningWord64 + :: (Operand -> Operand -> InstructionMetadata -> Instruction) + -> Operands Word64 + -> Operands Word64 + -> CodeGen arch (Operands (((), Word64), Word64)) +prim_wideningWord64 op (OP_Word64 x) (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)) + return $ OP_Unit `OP_Pair` upcastWord64 d `OP_Pair` upcastWord64 e -- Operations from Num -- ------------------- -addInt128# :: IRFun1 arch () ((Int128, Int128) -> Int128) -addInt128# = IRFun1 $ A.uncurry (prim_binaryInt128 (Add nsw nuw)) +addInt128# :: IRFun1 arch () (EltR (Int128, Int128) -> EltR Int128) +addInt128# = IRFun1 $ uncurry (prim_binaryInt128 (Add nsw nuw)) -subInt128# :: IRFun1 arch () ((Int128, Int128) -> Int128) -subInt128# = IRFun1 $ A.uncurry (prim_binaryInt128 (Sub nsw nuw)) +subInt128# :: IRFun1 arch () (EltR (Int128, Int128) -> EltR Int128) +subInt128# = IRFun1 $ uncurry (prim_binaryInt128 (Sub nsw nuw)) -mulInt128# :: IRFun1 arch () ((Int128, Int128) -> Int128) -mulInt128# = IRFun1 $ A.uncurry (prim_binaryInt128 (Mul nsw nuw)) +mulInt128# :: IRFun1 arch () (EltR (Int128, Int128) -> EltR Int128) +mulInt128# = IRFun1 $ uncurry (prim_binaryInt128 (Mul nsw nuw)) -addWord128# :: IRFun1 arch () ((Word128, Word128) -> Word128) -addWord128# = IRFun1 $ A.uncurry (prim_binaryWord128 (Add nsw nuw)) +addWord128# :: IRFun1 arch () (EltR (Word128, Word128) -> EltR Word128) +addWord128# = IRFun1 $ uncurry (prim_binaryWord128 (Add nsw nuw)) -subWord128# :: IRFun1 arch () ((Word128, Word128) -> Word128) -subWord128# = IRFun1 $ A.uncurry (prim_binaryWord128 (Sub nsw nuw)) +subWord128# :: IRFun1 arch () (EltR (Word128, Word128) -> EltR Word128) +subWord128# = IRFun1 $ uncurry (prim_binaryWord128 (Sub nsw nuw)) -mulWord128# :: IRFun1 arch () ((Word128, Word128) -> Word128) -mulWord128# = IRFun1 $ A.uncurry (prim_binaryWord128 (Mul nsw nuw)) +mulWord128# :: IRFun1 arch () (EltR (Word128, Word128) -> EltR Word128) +mulWord128# = IRFun1 $ uncurry (prim_binaryWord128 (Mul nsw nuw)) -- Operations from Integral -- ------------------------ -quotInt128# :: IRFun1 arch () ((Int128, Int128) -> Int128) -quotInt128# = IRFun1 $ A.uncurry (prim_binaryInt128 (SDiv False)) +quotInt128# :: IRFun1 arch () (EltR (Int128, Int128) -> EltR Int128) +quotInt128# = IRFun1 $ uncurry (prim_binaryInt128 (SDiv False)) -remInt128# :: IRFun1 arch () ((Int128, Int128) -> Int128) -remInt128# = IRFun1 $ A.uncurry (prim_binaryInt128 SRem) +remInt128# :: IRFun1 arch () (EltR (Int128, Int128) -> EltR Int128) +remInt128# = IRFun1 $ uncurry (prim_binaryInt128 SRem) -quotRemInt128# :: IRFun1 arch () ((Int128, Int128) -> (Int128,Int128)) -quotRemInt128# = IRFun1 $ A.uncurry quotRem' +quotRemInt128# :: IRFun1 arch () (EltR (Int128, Int128) -> EltR (Int128, Int128)) +quotRemInt128# = IRFun1 $ uncurry quotRem' where - quotRem' :: IR Int128 -> IR Int128 -> CodeGen (IR (Int128, Int128)) - quotRem' (IR xx) (IR yy) + quotRem' :: Operands (EltR Int128) -> Operands (EltR Int128) -> CodeGen arch (Operands (EltR (Int128, Int128))) + quotRem' xx 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 @@ -137,20 +152,20 @@ 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) + return $ OP_Unit `OP_Pair` upcastInt128 qh ql `OP_Pair` upcastInt128 rh rl -quotWord128# :: IRFun1 arch () ((Word128, Word128) -> Word128) -quotWord128# = IRFun1 $ A.uncurry (prim_binaryWord128 (UDiv False)) +quotWord128# :: IRFun1 arch () (EltR (Word128, Word128) -> EltR Word128) +quotWord128# = IRFun1 $ uncurry (prim_binaryWord128 (UDiv False)) -remWord128# :: IRFun1 arch () ((Word128, Word128) -> Word128) -remWord128# = IRFun1 $ A.uncurry (prim_binaryWord128 URem) +remWord128# :: IRFun1 arch () (EltR (Word128, Word128) -> EltR Word128) +remWord128# = IRFun1 $ uncurry (prim_binaryWord128 URem) -quotRemWord128# :: IRFun1 arch () ((Word128, Word128) -> (Word128,Word128)) -quotRemWord128# = IRFun1 $ A.uncurry quotRem' +quotRemWord128# :: IRFun1 arch () (EltR (Word128, Word128) -> EltR (Word128, Word128)) +quotRemWord128# = IRFun1 $ uncurry quotRem' where - quotRem' :: IR Word128 -> IR Word128 -> CodeGen (IR (Word128, Word128)) - quotRem' (IR xx) (IR yy) + quotRem' :: Operands (EltR Word128) -> Operands (EltR Word128) -> CodeGen arch (Operands (EltR (Word128, Word128))) + quotRem' xx 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 @@ -161,15 +176,19 @@ 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) + return $ OP_Unit `OP_Pair` upcastWord128 qh ql `OP_Pair` upcastWord128 rh rl -- Helpers -prim_binaryWord128 :: (Operand -> Operand -> InstructionMetadata -> Instruction) -> IR Word128 -> IR Word128 -> CodeGen (IR Word128) +prim_binaryWord128 + :: (Operand -> Operand -> InstructionMetadata -> Instruction) + -> Operands (EltR Word128) + -> Operands (EltR Word128) + -> CodeGen arch (Operands (EltR 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 + | 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) @@ -177,10 +196,14 @@ (hi,lo) <- unpackWord128 r return $ upcastWord128 hi lo -prim_binaryInt128 :: (Operand -> Operand -> InstructionMetadata -> Instruction) -> IR Int128 -> IR Int128 -> CodeGen (IR Int128) +prim_binaryInt128 + :: (Operand -> Operand -> InstructionMetadata -> Instruction) + -> Operands (EltR Int128) + -> Operands (EltR Int128) + -> CodeGen arch (Operands (EltR 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 + | 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' <- packInt128 (downcast xh) (downcast xl) y' <- packInt128 (downcast yh) (downcast yl) @@ -201,16 +224,16 @@ md :: InstructionMetadata md = [] -fresh :: CodeGen Name +fresh :: CodeGen arch Name fresh = downcast <$> freshName -instr :: Type -> Instruction -> CodeGen Operand +instr :: Type -> Instruction -> CodeGen arch Operand instr ty ins = do name <- fresh instr_ (name := ins) return (LocalReference ty name) -packInt128 :: Operand -> Operand -> CodeGen Operand +packInt128 :: Operand -> Operand -> CodeGen arch Operand packInt128 hi lo = do a <- instr i128 (SExt hi i128 md) b <- instr i128 (Shl nsw nuw a (ConstantOperand (Int 128 64)) md) @@ -218,7 +241,7 @@ d <- instr i128 (Or b c md) return d -packWord128 :: Operand -> Operand -> CodeGen Operand +packWord128 :: Operand -> Operand -> CodeGen arch Operand packWord128 hi lo = do a <- instr i128 (ZExt hi i128 md) b <- instr i128 (Shl nsw nuw a (ConstantOperand (Int 128 64)) md) @@ -226,31 +249,31 @@ d <- instr i128 (Or b c md) return d -unpackInt128 :: Operand -> CodeGen (Operand,Operand) +unpackInt128 :: Operand -> CodeGen arch (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 :: Operand -> CodeGen arch (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 :: HasCallStack => Operand -> Operands Int64 upcastInt64 (LocalReference (IntegerType 64) (UnName x)) = OP_Int64 (A.LocalReference A.type' (A.UnName x)) -upcastInt64 _ = $internalError "upcastInt64" "expected local reference" +upcastInt64 _ = internalError "expected local reference" -upcastWord64 :: Operand -> Operands Word64 +upcastWord64 :: HasCallStack => Operand -> Operands Word64 upcastWord64 (LocalReference (IntegerType 64) (UnName x)) = OP_Word64 (A.LocalReference A.type' (A.UnName x)) -upcastWord64 _ = $internalError "upcastWord64" "expected local reference" +upcastWord64 _ = internalError "expected local reference" -upcastInt128 :: Operand -> Operand -> IR Int128 -upcastInt128 hi lo = IR $ OP_Pair (OP_Pair OP_Unit (upcastInt64 hi)) (upcastWord64 lo) +upcastInt128 :: Operand -> Operand -> Operands (EltR Int128) +upcastInt128 hi lo = 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) +upcastWord128 :: Operand -> Operand -> Operands (EltR Word128) +upcastWord128 hi lo = OP_Pair (OP_Pair OP_Unit (upcastWord64 hi)) (upcastWord64 lo) diff --git a/src/Data/Array/Accelerate/Internal/Num2.hs b/src/Data/Array/Accelerate/Internal/Num2.hs --- a/src/Data/Array/Accelerate/Internal/Num2.hs +++ b/src/Data/Array/Accelerate/Internal/Num2.hs @@ -7,10 +7,10 @@ {-# LANGUAGE UnboxedTuples #-} -- | -- Module : Data.Array.Accelerate.Internal.Num2 --- Copyright : [2016] Trevor L. McDonell +-- Copyright : [2016..2020] Trevor L. McDonell -- License : BSD3 -- --- Maintainer : Trevor L. McDonell +-- Maintainer : Trevor L. McDonell -- Stability : experimental -- Portability : non-portable (GHC extensions) -- diff --git a/src/Data/Array/Accelerate/Internal/Orphans.hs b/src/Data/Array/Accelerate/Internal/Orphans.hs --- a/src/Data/Array/Accelerate/Internal/Orphans.hs +++ b/src/Data/Array/Accelerate/Internal/Orphans.hs @@ -1,9 +1,9 @@ -- | -- Module : Data.Array.Accelerate.Internal.Orphans --- Copyright : [2016] Trevor L. McDonell +-- Copyright : [2016..2020] Trevor L. McDonell -- License : BSD3 -- --- Maintainer : Trevor L. McDonell +-- Maintainer : Trevor L. McDonell -- Stability : experimental -- Portability : non-portable (GHC extensions) -- diff --git a/src/Data/Array/Accelerate/Internal/Orphans/Base.hs b/src/Data/Array/Accelerate/Internal/Orphans/Base.hs --- a/src/Data/Array/Accelerate/Internal/Orphans/Base.hs +++ b/src/Data/Array/Accelerate/Internal/Orphans/Base.hs @@ -8,6 +8,7 @@ {-# LANGUAGE RebindableSyntax #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TypeApplications #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TypeOperators #-} {-# LANGUAGE UndecidableInstances #-} @@ -15,10 +16,10 @@ {-# OPTIONS_GHC -fno-warn-orphans #-} -- | -- Module : Data.Array.Accelerate.Internal.Orphans.Base --- Copyright : [2016] Trevor L. McDonell +-- Copyright : [2016..2020] Trevor L. McDonell -- License : BSD3 -- --- Maintainer : Trevor L. McDonell +-- Maintainer : Trevor L. McDonell -- Stability : experimental -- Portability : non-portable (GHC extensions) -- @@ -27,29 +28,30 @@ -- excessive class constraints by placing instances next to each other. -- +#include "MachDeps.h" + 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 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 hiding ( fromInteger ) -import Data.Array.Accelerate.Array.Sugar as A ( eltType ) +import Data.Array.Accelerate.Sugar.Elt 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 Unsafe.Coerce +import Prelude ( id, fromInteger ) import qualified Prelude as P @@ -64,25 +66,22 @@ , 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 + minBound = W2_ minBound minBound + maxBound = W2_ 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 + W2_ xh xl == W2_ yh yl = xh == yh && xl == yl + W2_ xh xl /= 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 ) + W2_ xh xl < W2_ yh yl = xh == yh ? ( xl < yl, xh < yh ) + W2_ xh xl > W2_ yh yl = xh == yh ? ( xl > yl, xh > yh ) + W2_ xh xl <= W2_ yh yl = xh == yh ? ( xl <= yl, xh <= yh ) + W2_ xh xl >= W2_ yh yl = xh == yh ? ( xl >= yl, xh >= yh ) instance ( Num a @@ -92,35 +91,35 @@ , BigWordCtx a b ) => P.Num (Exp (BigWord a b)) where - negate (unlift -> W2 hi lo) = + negate (W2_ hi lo) = if lo == 0 - then mkW2 (negate hi) 0 - else mkW2 (negate (hi+1)) (negate lo) + then W2_ (negate hi) 0 + else W2_ (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 + (+) | Just Refl <- matchWord128 @(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 + add (W2_ xh xl) (W2_ yh yl) = W2_ 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 + (-) | Just Refl <- matchWord128 @(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 + (*) | Just Refl <- matchWord128 @(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 + mul (W2_ xh xl) (W2_ yh yl) = W2_ hi lo where hi = xh * fromIntegral yl + yh * fromIntegral xl + fromIntegral c (c,lo) = mulWithCarry xl yl @@ -146,86 +145,85 @@ 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 + quot | Just Refl <- matchWord128 @(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 + rem | Just Refl <- matchWord128 @(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' + quotRem | Just Refl <- matchWord128 @(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) + quotRem' x@(W2_ xh xl) y@(W2_ yh yl) + = xh < yh ? ( T2 0 x + , xh == yh ? ( xl < yl ? ( T2 0 x + , xl == yl ? ( T2 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)) + in lift (W2_ 0 t2, W2_ 0 t1) + , T2 1 (W2_ 0 (xl-yl)) ) )) ,{- xh > yh -} yl == 0 ? ( let (t2,t1) = quotRem xh yh - in lift (mkW2 0 (fromIntegral t2), W2 t1 xl) + in lift (W2_ 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) + ( T2 ((W2_ 0 z) + 1) 0 + , T2 (W2_ 0 z) (W2_ 0 t1) ) , t1 == maxBound ? - ( tup2 ((mkW2 0 z) + 2, 1) + ( T2 ((W2_ 0 z) + 2) 1 , t1 == xor maxBound 1 ? - ( tup2 ((mkW2 0 z) + 2, 0) - , tup2 ((mkW2 0 z) + 1, mkW2 0 (t1+1)) + ( T2 ((W2_ 0 z) + 2) 0 + , T2 ((W2_ 0 z) + 1) (W2_ 0 (t1+1)) ) ) ) , yh == 0 ? ( let (t2,t1) = untup2 (div1 xh xl yl) - in tup2 (t2, mkW2 0 t1) + in T2 t2 (W2_ 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) + 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 = u + W2_ lhh lll = v + -- z hhh hll / lhh lll + (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 :: Exp b + qr2 = t5 > t6 ? + ( loWord t8 == 0 ? + ( t7 >= t5 ? + ( T2 (q1-1) (t7-t5) + , loWord t10 == 0 ? + ( T2 (q1-2) (t9-t5) + , T2 (q1-2) ((maxBound-t5) + t9 + 1) + ) + ) + , T2 (q1-1) ((maxBound-t5) + t7 + 1) + ) + , T2 (q1) (t6-t5) ) - ) - , tup2 (q1-1, (maxBound-t5) + t7 + 1) - ) - , tup2 (q1, t6-t5) - ) - (q2,r2) = unlift qr2 + (q2,r2) = untup2 qr2 in - t1 == t2 ? ( tup2 (1, x-y) - , lift (mkW2 0 (fromIntegral q2), shiftR r2 t2) + t1 == t2 ? ( T2 1 (x-y) + , lift (W2_ 0 (fromIntegral q2), shiftR r2 t2) ) ))) )) @@ -247,7 +245,7 @@ (t6, _t5) = addWithCarry t3 l z = t4 + t6 - body h l c = lift (fromIntegral z, t5, c + (mkW2 (fromIntegral t8) t7)) + body h l c = lift (fromIntegral z, t5, c + (W2_ (fromIntegral t8) t7)) where h1 = fromIntegral h (t4, t3) = mulWithCarry h1 (t1 + 1) @@ -255,7 +253,7 @@ z = t4 + t6 (t8, t7) = mulWithCarry h1 t2 - after h l c = lift (c + mkW2 (fromIntegral t8) t7 + mkW2 0 t10, t9) + after h l c = lift (c + W2_ (fromIntegral t8) t7 + W2_ 0 t10, t9) where h1 = fromIntegral h (_t4, t3) = mulWithCarry h1 (t1 + 1) @@ -265,7 +263,7 @@ div2 :: Exp a -> Exp a -> Exp a -> (Exp a, Exp a) - div2 hhh hll by = go hhh hll (tup2 (0,0)) + div2 hhh hll by = go hhh hll (T2 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)) @@ -280,7 +278,7 @@ 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))) + body h l c = lift (z, t5, (addT (untup2 c) (t8,t7))) where (t4, t3) = mulWithCarry h (t1 + 1) (t6, t5) = addWithCarry t3 l @@ -294,7 +292,7 @@ (_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) + q = addT (untup2 (addT (untup2 c) (t8, t7))) (0, t10) addT :: (Exp a, Exp a) -> (Exp a, Exp a) -> Exp (a,a) addT (lhh, lhl) (llh, lll) = @@ -315,19 +313,19 @@ 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 + signed (W2_ hi lo) = I2_ (signed hi) lo unsigned = id -- - addWithCarry (unlift -> W2 xh xl) (unlift -> W2 yh yl) = (mkW2 0 w, mkW2 v u) + 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 (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) + 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 @@ -351,19 +349,19 @@ 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) + 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 (unlift -> W2 hi lo) x = + shiftL (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) + then W2_ (shiftL hi x .|. fromIntegral (shiftR lo y)) (shiftL lo x) + else W2_ (fromIntegral (shiftL lo (negate y))) (0::Exp b) where y = finiteBitSize (undefined::Exp b) - x - shiftR (unlift -> W2 hi lo) x = mkW2 hi' lo' + shiftR (W2_ hi lo) x = W2_ hi' lo' where hi' = shiftR hi x lo' = if y >= 0 then shiftL (fromIntegral hi) y .|. shiftR lo x @@ -372,12 +370,12 @@ y = finiteBitSize (undefined::Exp b) - x z = shiftR (fromIntegral hi) (negate y) - rotateL (unlift -> W2 hi lo) x = + rotateL (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) + then W2_ (fromIntegral (shiftL lo y) .|. shiftR hi z) + (shiftL (fromIntegral hi) (finiteBitSize (undefined::Exp b) - z) .|. shiftR lo z) + else W2_ (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 @@ -386,40 +384,40 @@ bit n = if m >= 0 - then mkW2 (bit m) 0 - else mkW2 0 (bit n) + then W2_ (bit m) 0 + else W2_ 0 (bit n) where m = n - finiteBitSize (undefined::Exp b) - testBit (unlift -> W2 hi lo) n = + testBit (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 = + setBit (W2_ hi lo) n = if m >= 0 - then mkW2 (setBit hi m) lo - else mkW2 hi (setBit lo n) + then W2_ (setBit hi m) lo + else W2_ hi (setBit lo n) where m = n - finiteBitSize (undefined::Exp b) - clearBit (unlift -> W2 hi lo) n = + clearBit (W2_ hi lo) n = if m >= 0 - then mkW2 (clearBit hi m) lo - else mkW2 hi (clearBit lo n) + then W2_ (clearBit hi m) lo + else W2_ hi (clearBit lo n) where m = n - finiteBitSize (undefined::Exp b) - complementBit (unlift -> W2 hi lo) n = + complementBit (W2_ hi lo) n = if m >= 0 - then mkW2 (complementBit hi m) lo - else mkW2 hi (complementBit lo n) + then W2_ (complementBit hi m) lo + else W2_ hi (complementBit lo n) where m = n - finiteBitSize (undefined::Exp b) - popCount (unlift -> W2 hi lo) = popCount hi + popCount lo + popCount (W2_ hi lo) = popCount hi + popCount lo instance ( Integral a, FiniteBits a, FromIntegral a b @@ -430,14 +428,14 @@ finiteBitSize _ = finiteBitSize (undefined::Exp a) + finiteBitSize (undefined::Exp b) - countLeadingZeros (unlift -> W2 hi lo) = + countLeadingZeros (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) = + countTrailingZeros (W2_ hi lo) = ltz == wsib ? (wsib + htz, ltz) where ltz = countTrailingZeros lo @@ -457,25 +455,22 @@ , 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 + minBound = I2_ minBound minBound + maxBound = I2_ 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 + I2_ xh xl == I2_ yh yl = xh == yh && xl == yl + I2_ xh xl /= 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 ) + I2_ xh xl < I2_ yh yl = xh == yh ? ( xl < yl, xh < yh ) + I2_ xh xl > I2_ yh yl = xh == yh ? ( xl > yl, xh > yh ) + I2_ xh xl <= I2_ yh yl = xh == yh ? ( xl <= yl, xh <= yh ) + I2_ xh xl >= I2_ yh yl = xh == yh ? ( xl >= yl, xh >= yh ) instance ( Num a, Ord a @@ -487,15 +482,15 @@ , BigIntCtx a b ) => P.Num (Exp (BigInt a b)) where - negate (unlift -> I2 hi lo) = + negate (I2_ hi lo) = if lo == 0 - then mkI2 (negate hi) 0 - else mkI2 (negate (hi+1)) (negate lo) + then I2_ (negate hi) 0 + else I2_ (negate (hi+1)) (negate lo) - signum (unlift -> I2 hi lo :: BigInt (Exp a) (Exp b)) = - if hi < 0 then mkI2 (-1) maxBound else + signum (I2_ hi lo) = + if hi < 0 then I2_ (-1) maxBound else if hi == 0 then if lo == 0 then 0 else 1 - else mkI2 0 1 + else I2_ 0 1 abs x = if x < 0 then negate x @@ -504,22 +499,22 @@ fromInteger = constant . fromInteger {-# SPECIALIZE (+) :: Exp Int128 -> Exp Int128 -> Exp Int128 #-} - (+) | Just Refl <- matchInt128 (undefined::BigInt a b) = CPU.addInt128# $ PTX.addInt128# add - | otherwise = add + (+) | Just Refl <- matchInt128 @(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 + add (I2_ xh xl) (I2_ yh yl) = I2_ 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 + (-) | Just Refl <- matchInt128 @(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 + (*) | Just Refl <- matchInt128 @(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) @@ -541,37 +536,37 @@ toInteger = error "Prelude.toInteger is 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 + quot | Just Refl <- matchInt128 @(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 + rem | Just Refl <- matchInt128 @(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' + quotRem | Just Refl <- matchInt128 @(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)) + in T2 (signed q) (signed (negate r)) else let (q,r) = quotRem (negate (unsigned x)) (unsigned y) - in tup2 (signed (negate q), signed (negate r)) + in T2 (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) + in T2 (signed (negate q)) (signed r) else let (q,r) = quotRem (unsigned x) (unsigned y) - in tup2 (signed q, signed r) + in T2 (signed q) (signed r) {-# SPECIALIZE div :: Exp Int128 -> Exp Int128 -> Exp Int128 #-} {-# SPECIALIZE mod :: Exp Int128 -> Exp Int128 -> Exp Int128 #-} @@ -583,23 +578,23 @@ 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)) + in T2 (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) + if r == 0 then T2 q' r' + else T2 (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) + then T2 q' r' + else T2 (q'-1) (r'+y) else let (q,r) = quotRem (unsigned x) (unsigned y) - in tup2 (signed q, signed r) + in T2 (signed q) (signed r) instance ( FiniteBits a, Integral a, FromIntegral a b, FromIntegral a (Signed b) @@ -614,19 +609,19 @@ => 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) + 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 (unlift -> I2 hi lo) x = + shiftL (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 + then I2_ (shiftL hi x .|. fromIntegral (shiftR lo y)) (shiftL lo x) + else I2_ (fromIntegral (shiftL lo (negate y))) 0 where y = finiteBitSize (undefined::Exp b) - x - shiftR (unlift -> I2 hi lo) x = mkI2 hi' lo' + shiftR (I2_ hi lo) x = I2_ hi' lo' where hi' = shiftR hi x lo' = if y >= 0 then shiftL (fromIntegral hi) y .|. shiftR lo x @@ -639,36 +634,36 @@ 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) + if m >= 0 then I2_ (bit m) 0 + else I2_ 0 (bit n) where m = n - finiteBitSize (undefined::Exp b) - testBit (unlift -> I2 hi lo) n = + testBit (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) + setBit (I2_ hi lo) n = + if m >= 0 then I2_ (setBit hi m) lo + else I2_ 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) + clearBit (I2_ hi lo) n = + if m >= 0 then I2_ (clearBit hi m) lo + else I2_ 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) + complementBit (I2_ hi lo) n = + if m >= 0 then I2_ (complementBit hi m) lo + else I2_ hi (complementBit lo n) where m = n - finiteBitSize (undefined::Exp b) - popCount (unlift -> I2 hi lo) = popCount hi + popCount lo + popCount (I2_ hi lo) = popCount hi + popCount lo instance ( FiniteBits a @@ -704,7 +699,7 @@ type Unsigned (Exp (BigInt a b)) = Exp (BigWord (Unsigned a) b) -- signed = id - unsigned (unlift -> I2 (hi::Exp a) lo) = mkW2 (unsigned hi) lo + unsigned (I2_ hi lo) = W2_ (unsigned hi) lo -- addWithCarry x y = (c, r) where @@ -713,7 +708,7 @@ (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) + mulWithCarry x@(I2_ xh _) y@(I2_ yh _) = (hi,lo) where t1 = complement y + 1 t2 = complement x + 1 @@ -793,7 +788,7 @@ unsigned = fromIntegral addWithCarry = untup2 $$ CPU.addWithCarryInt64# $ PTX.addWithCarryInt64# awc where - awc x y = tup2 (hi,lo) + awc x y = T2 hi lo where extX = x < 0 ? (maxBound, 0) extY = y < 0 ? (maxBound, 0) @@ -802,7 +797,7 @@ mulWithCarry = untup2 $$ CPU.mulWithCarryInt64# $ PTX.mulWithCarryInt64# mwc where - mwc x y = tup2 (hi,lo) + mwc x y = T2 hi lo where extX = x < 0 ? (negate y, 0) extY = y < 0 ? (negate x, 0) @@ -817,14 +812,14 @@ unsigned = id addWithCarry = untup2 $$ CPU.addWithCarryWord64# $ PTX.addWithCarryWord64# awc where - awc x y = tup2 (hi,lo) + awc x y = T2 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) + mwc x y = T2 hi lo where xHi = shiftR x 32 yHi = shiftR y 32 @@ -858,18 +853,24 @@ -- 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 _ +untup2 :: (Elt a, Elt b) => Exp (a, b) -> (Exp a, Exp b) +untup2 (T2 a b) = (a, b) + +untup3 :: (Elt a, Elt b, Elt c) => Exp (a, b, c) -> (Exp a, Exp b, Exp c) +untup3 (T3 a b c) = (a, b, c) + +matchInt128 :: forall t. Elt t => Maybe (t :~: Int128) +matchInt128 + | Just Refl <- matchTypeR (eltR @t) (eltR @Int128) + = Just (unsafeCoerce Refl) + | otherwise = 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 _ +matchWord128 :: forall t. Elt t => Maybe (t :~: Word128) +matchWord128 + | Just Refl <- matchTypeR (eltR @t) (eltR @Word128) + = Just (unsafeCoerce Refl) + | otherwise = Nothing @@ -922,62 +923,115 @@ fromIntegral = id instance FromIntegral $(bigIntT big) $(bigWordT big) where - fromIntegral (unlift -> I2 hi lo) = mkW2 (fromIntegral hi) lo + fromIntegral (I2_ hi lo) = W2_ (fromIntegral hi) lo instance FromIntegral $(bigWordT big) $(bigIntT big) where - fromIntegral (unlift -> W2 hi lo) = mkI2 (fromIntegral hi) lo + fromIntegral (W2_ hi lo) = I2_ (fromIntegral hi) lo + + instance FromIntegral Int $(bigIntT big) where + fromIntegral x = +#if WORD_SIZE_IN_BITS == 32 + fromIntegral (fromIntegral x :: Exp Int32) +#elif WORD_SIZE_IN_BITS == 64 + fromIntegral (fromIntegral x :: Exp Int64) +#endif + + instance FromIntegral Int $(bigWordT big) where + fromIntegral x = +#if WORD_SIZE_IN_BITS == 32 + fromIntegral (fromIntegral x :: Exp Int32) +#elif WORD_SIZE_IN_BITS == 64 + fromIntegral (fromIntegral x :: Exp Int64) +#endif + + instance FromIntegral Word $(bigIntT big) where + fromIntegral x = +#if WORD_SIZE_IN_BITS == 32 + fromIntegral (fromIntegral x :: Exp Word32) +#elif WORD_SIZE_IN_BITS == 64 + fromIntegral (fromIntegral x :: Exp Word64) +#endif + + instance FromIntegral Word $(bigWordT big) where + fromIntegral x = +#if WORD_SIZE_IN_BITS == 32 + fromIntegral (fromIntegral x :: Exp Word32) +#elif WORD_SIZE_IN_BITS == 64 + fromIntegral (fromIntegral x :: Exp Word64) +#endif |] thFromIntegral2 :: (Int,Int) -> Int -> Q [Dec] - thFromIntegral2 big@(bigH,bigL) little = + thFromIntegral2 big little = [d| -- convert from primitive type to bignum type instance FromIntegral $(wordT little) $(bigWordT big) where - fromIntegral x = mkW2 0 (fromIntegral x) + fromIntegral x = W2_ 0 (fromIntegral x) instance FromIntegral $(wordT little) $(bigIntT big) where - fromIntegral x = mkI2 0 (fromIntegral x) + fromIntegral x = I2_ 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' + if x < 0 then W2_ maxBound x' + else W2_ 0 x' instance FromIntegral $(intT little) $(bigIntT big) where fromIntegral x@(fromIntegral -> x') = - if x < 0 then mkI2 (-1) x' - else mkI2 0 x' + if x < 0 then I2_ (-1) x' + else I2_ 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 + fromIntegral (W2_ _ lo) = 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 + fromIntegral (W2_ _ lo) = 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 + fromIntegral (I2_ _ lo) = 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 + fromIntegral (I2_ _ lo) = fromIntegral lo |] + + thToFloating :: (Int,Int) -> Q [Dec] + thToFloating big@(_,b) = + [d| + instance ToFloating $(bigIntT big) Half where + toFloating (I2_ hi lo) = + toFloating hi * (P.fromIntegral (maxBound :: $(wordT b)) + 1) + toFloating lo + + instance ToFloating $(bigIntT big) Float where + toFloating (I2_ hi lo) = + toFloating hi * (P.fromIntegral (maxBound :: $(wordT b)) + 1) + toFloating lo + + instance ToFloating $(bigIntT big) Double where + toFloating (I2_ hi lo) = + toFloating hi * (P.fromIntegral (maxBound :: $(wordT b)) + 1) + toFloating lo + + instance ToFloating $(bigWordT big) Half where + toFloating (W2_ hi lo) = + toFloating hi * (P.fromIntegral (maxBound :: $(wordT b)) + 1) + toFloating lo + + instance ToFloating $(bigWordT big) Float where + toFloating (W2_ hi lo) = + toFloating hi * (P.fromIntegral (maxBound :: $(wordT b)) + 1) + toFloating lo + + instance ToFloating $(bigWordT big) Double where + toFloating (W2_ hi lo) = + toFloating hi * (P.fromIntegral (maxBound :: $(wordT b)) + 1) + toFloating lo + |] -- #if MIN_VERSION_accelerate(1,2,0) e1 <- sequence [ thEnum x | x <- bigNums ] #else - e1 <- return [] + e1 <- return [] #endif d1 <- sequence [ thFromIntegral1 x | x <- bigNums ] d2 <- sequence [ thFromIntegral2 x y | x <- bigNums, y <- lilNums ] + d3 <- sequence [ thToFloating x | x <- bigNums ] -- - return $ P.concat (e1 P.++ d1 P.++ d2) + return $ P.concat (e1 P.++ d1 P.++ d2 P.++ d3) ) diff --git a/src/Data/Array/Accelerate/Internal/Orphans/Elt.hs b/src/Data/Array/Accelerate/Internal/Orphans/Elt.hs --- a/src/Data/Array/Accelerate/Internal/Orphans/Elt.hs +++ b/src/Data/Array/Accelerate/Internal/Orphans/Elt.hs @@ -2,82 +2,62 @@ {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE PatternSynonyms #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE UndecidableInstances #-} {-# OPTIONS_GHC -fno-warn-orphans #-} -- | -- Module : Data.Array.Accelerate.Internal.Orphans.Elt --- Copyright : [2016] Trevor L. McDonell +-- Copyright : [2016..2020] Trevor L. McDonell -- License : BSD3 -- --- Maintainer : Trevor L. McDonell +-- Maintainer : Trevor L. McDonell -- Stability : experimental -- Portability : non-portable (GHC extensions) -- -- Orphan Elt instances for BigWord and BigInt -- -module Data.Array.Accelerate.Internal.Orphans.Elt () - where +module Data.Array.Accelerate.Internal.Orphans.Elt ( -import Data.Array.Accelerate.Internal.BigInt -import Data.Array.Accelerate.Internal.BigWord + pattern W2_, + pattern I2_, -import Data.Array.Accelerate -import Data.Array.Accelerate.Array.Sugar -import Data.Array.Accelerate.Product -import Data.Array.Accelerate.Smart +) where +import Data.Array.Accelerate.Internal.BigInt +import Data.Array.Accelerate.Internal.BigWord -type instance EltRepr (BigInt a b) = EltRepr (a,b) -type instance EltRepr (BigWord a b) = EltRepr (a,b) +import Data.Array.Accelerate hiding ( pattern I2 ) -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 (Elt a, Elt b) => Elt (BigWord 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)) +pattern W2_ :: (Elt a, Elt b) => Exp a -> Exp b -> Exp (BigWord a b) +pattern W2_ a b = Pattern (a, b) +{-# COMPLETE W2_ #-} -instance (Lift Exp a, Lift Exp b, Elt (Plain a), Elt (Plain b), Show (BigWord (Plain a) (Plain b))) +instance (Lift Exp a, Lift Exp b, Elt (Plain a), Elt (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) + lift (W2 a b) = W2_ (lift a) (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) => Unlift Exp (BigWord (Exp a) (Exp b)) where + unlift (W2_ a b) = 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 (Elt a, Elt b) => Elt (BigInt 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)) +pattern I2_ :: (Elt a, Elt b) => Exp a -> Exp b -> Exp (BigInt a b) +pattern I2_ a b = Pattern (a, b) +{-# COMPLETE I2_ #-} -instance (Lift Exp a, Lift Exp b, Elt (Plain a), Elt (Plain b), Show (BigInt (Plain a) (Plain b))) +instance (Lift Exp a, Lift Exp b, Elt (Plain a), Elt (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) + lift (I2 a b) = I2_ (lift a) (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 +instance (Elt a, Elt b) => Unlift Exp (BigInt (Exp a) (Exp b)) where + unlift (I2_ a b) = I2 a b diff --git a/test/Test/Base.hs b/test/Test/Base.hs --- a/test/Test/Base.hs +++ b/test/Test/Base.hs @@ -4,10 +4,10 @@ {-# LANGUAGE RankNTypes #-} -- | -- Module : Test.Base --- Copyright : [2017] Trevor L. McDonell +-- Copyright : [2017..2020] Trevor L. McDonell -- License : BSD3 -- --- Maintainer : Trevor L. McDonell +-- Maintainer : Trevor L. McDonell -- Stability : experimental -- Portability : non-portable (GHC extensions) -- @@ -15,8 +15,9 @@ module Test.Base where import Data.Array.Accelerate ( Acc, Arrays, Array, Shape, Elt, fromList ) -import Data.Array.Accelerate.Array.Sugar ( size ) -import Data.Array.Accelerate.Trafo ( Afunction, AfunctionR ) +import Data.Array.Accelerate.Sugar.Shape ( size ) +import Data.Array.Accelerate.Trafo ( Afunction ) +import Data.Array.Accelerate.Trafo.Sharing ( AfunctionR ) import Data.Array.Accelerate.Data.Complex import Data.Array.Accelerate.Data.BigInt diff --git a/test/Test/BigNum.hs b/test/Test/BigNum.hs --- a/test/Test/BigNum.hs +++ b/test/Test/BigNum.hs @@ -1,10 +1,10 @@ {-# LANGUAGE RankNTypes #-} -- | -- Module : Test.BigNum --- Copyright : [2017] Trevor L. McDonell +-- Copyright : [2017..2020] Trevor L. McDonell -- License : BSD3 -- --- Maintainer : Trevor L. McDonell +-- Maintainer : Trevor L. McDonell -- Stability : experimental -- Portability : non-portable (GHC extensions) -- diff --git a/test/Test/BigNum/Bits.hs b/test/Test/BigNum/Bits.hs --- a/test/Test/BigNum/Bits.hs +++ b/test/Test/BigNum/Bits.hs @@ -4,10 +4,10 @@ {-# LANGUAGE ScopedTypeVariables #-} -- | -- Module : Test.BigNum.Bits --- Copyright : [2017] Trevor L. McDonell +-- Copyright : [2017..2020] Trevor L. McDonell -- License : BSD3 -- --- Maintainer : Trevor L. McDonell +-- Maintainer : Trevor L. McDonell -- Stability : experimental -- Portability : non-portable (GHC extensions) -- @@ -70,7 +70,7 @@ , testProperty "popCount" $ prop_popCount a b ] - testAcc :: (Eq a, FiniteBits a, A.FiniteBits a, Show (ArgType a)) + testAcc :: (Show a, Eq a, FiniteBits a, A.FiniteBits a, Show (ArgType a)) => Gen a -> TestTree testAcc a = @@ -266,7 +266,7 @@ prop_unary' popCount popCount b x prop_acc_complement - :: (Bits a, A.Bits a) + :: (Show a, Bits a, A.Bits a) => RunN -> Gen a -> Property @@ -276,7 +276,7 @@ prop_acc_unary complement A.complement runN x prop_acc_xor - :: (Bits a, A.Bits a) + :: (Show a, Bits a, A.Bits a) => RunN -> Gen a -> Property @@ -287,7 +287,7 @@ prop_acc_binary xor A.xor runN x y prop_acc_band - :: (Bits a, A.Bits a) + :: (Show a, Bits a, A.Bits a) => RunN -> Gen a -> Property @@ -298,7 +298,7 @@ prop_acc_binary (.&.) (A..&.) runN x y prop_acc_bor - :: (Bits a, A.Bits a) + :: (Show a, Bits a, A.Bits a) => RunN -> Gen a -> Property @@ -310,7 +310,7 @@ prop_acc_shiftL - :: (FiniteBits a, A.FiniteBits a) + :: (Show a, FiniteBits a, A.FiniteBits a) => RunN -> Gen a -> Property @@ -321,7 +321,7 @@ prop_acc_binary shiftL A.shiftL runN x n prop_acc_shiftR - :: (FiniteBits a, A.FiniteBits a) + :: (Show a, FiniteBits a, A.FiniteBits a) => RunN -> Gen a -> Property @@ -332,7 +332,7 @@ prop_acc_binary shiftR A.shiftR runN x n prop_acc_rotateL - :: (FiniteBits a, A.FiniteBits a) + :: (Show a, FiniteBits a, A.FiniteBits a) => RunN -> Gen a -> Property @@ -343,7 +343,7 @@ prop_acc_binary rotateL A.rotateL runN x n prop_acc_rotateR - :: (FiniteBits a, A.FiniteBits a) + :: (Show a, FiniteBits a, A.FiniteBits a) => RunN -> Gen a -> Property @@ -354,7 +354,7 @@ prop_acc_binary rotateR A.rotateR runN x n prop_acc_shift - :: (FiniteBits a, A.FiniteBits a) + :: (Show a, FiniteBits a, A.FiniteBits a) => RunN -> Gen a -> Property @@ -365,7 +365,7 @@ prop_acc_binary shift A.shift runN x n prop_acc_rotate - :: (FiniteBits a, A.FiniteBits a) + :: (Show a, FiniteBits a, A.FiniteBits a) => RunN -> Gen a -> Property @@ -376,7 +376,7 @@ prop_acc_binary rotate A.rotate runN x n prop_acc_bit - :: forall proxy a. (FiniteBits a, A.FiniteBits a) + :: forall proxy a. (Show a, FiniteBits a, A.FiniteBits a) => RunN -> proxy a -> Property @@ -386,7 +386,7 @@ prop_acc_testBit - :: (FiniteBits a, A.FiniteBits a) + :: (Show a, FiniteBits a, A.FiniteBits a) => RunN -> Gen a -> Property @@ -397,7 +397,7 @@ prop_acc_binary testBit A.testBit runN x n prop_acc_setBit - :: (FiniteBits a, A.FiniteBits a) + :: (Show a, FiniteBits a, A.FiniteBits a) => RunN -> Gen a -> Property @@ -408,7 +408,7 @@ prop_acc_binary setBit A.setBit runN x n prop_acc_clearBit - :: (FiniteBits a, A.FiniteBits a) + :: (Show a, FiniteBits a, A.FiniteBits a) => RunN -> Gen a -> Property @@ -419,7 +419,7 @@ prop_acc_binary clearBit A.clearBit runN x n prop_acc_complementBit - :: (FiniteBits a, A.FiniteBits a) + :: (Show a, FiniteBits a, A.FiniteBits a) => RunN -> Gen a -> Property @@ -430,7 +430,7 @@ prop_acc_binary complementBit A.complementBit runN x n prop_acc_popCount - :: (FiniteBits a, A.FiniteBits a) + :: (Show a, FiniteBits a, A.FiniteBits a) => RunN -> Gen a -> Property diff --git a/test/Test/BigNum/Bounded.hs b/test/Test/BigNum/Bounded.hs --- a/test/Test/BigNum/Bounded.hs +++ b/test/Test/BigNum/Bounded.hs @@ -4,10 +4,10 @@ {-# LANGUAGE ScopedTypeVariables #-} -- | -- Module : Test.BigNum.Bounded --- Copyright : [2017] Trevor L. McDonell +-- Copyright : [2017..2020] Trevor L. McDonell -- License : BSD3 -- --- Maintainer : Trevor L. McDonell +-- Maintainer : Trevor L. McDonell -- Stability : experimental -- Portability : non-portable (GHC extensions) -- @@ -52,7 +52,7 @@ , testProperty "maxBound" $ prop_maxBound p ] - testAcc :: (Eq a, Bounded a, A.Bounded a, Show (ArgType a)) + testAcc :: (Show a, Eq a, Bounded a, A.Bounded a, Show (ArgType a)) => Proxy a -> TestTree testAcc p = @@ -79,7 +79,7 @@ maxBound === fromIso p maxBound prop_acc_minBound - :: forall a. (Eq a, Bounded a, A.Bounded a) + :: forall a. (Show a, Eq a, Bounded a, A.Bounded a) => RunN -> Proxy a -> Property @@ -88,7 +88,7 @@ minBound === isoL (runN (A.unit (minBound :: A.Exp a))) prop_acc_maxBound - :: forall a. (Eq a, Bounded a, A.Bounded a) + :: forall a. (Show a, Eq a, Bounded a, A.Bounded a) => RunN -> Proxy a -> Property diff --git a/test/Test/BigNum/Enum.hs b/test/Test/BigNum/Enum.hs --- a/test/Test/BigNum/Enum.hs +++ b/test/Test/BigNum/Enum.hs @@ -2,10 +2,10 @@ {-# LANGUAGE FlexibleContexts #-} -- | -- Module : Test.BigNum.Enum --- Copyright : [2017] Trevor L. McDonell +-- Copyright : [2017..2020] Trevor L. McDonell -- License : BSD3 -- --- Maintainer : Trevor L. McDonell +-- Maintainer : Trevor L. McDonell -- Stability : experimental -- Portability : non-portable (GHC extensions) -- diff --git a/test/Test/BigNum/Eq.hs b/test/Test/BigNum/Eq.hs --- a/test/Test/BigNum/Eq.hs +++ b/test/Test/BigNum/Eq.hs @@ -3,10 +3,10 @@ {-# LANGUAGE RankNTypes #-} -- | -- Module : Test.BigNum.Eq --- Copyright : [2017] Trevor L. McDonell +-- Copyright : [2017..2020] Trevor L. McDonell -- License : BSD3 -- --- Maintainer : Trevor L. McDonell +-- Maintainer : Trevor L. McDonell -- Stability : experimental -- Portability : non-portable (GHC extensions) -- @@ -50,7 +50,7 @@ , testProperty "(/=)" $ prop_neq a b ] - testAcc :: (Eq a, A.Eq a, Show (ArgType a)) + testAcc :: (Show a, Eq a, A.Eq a, Show (ArgType a)) => Gen a -> TestTree testAcc a = @@ -83,7 +83,7 @@ prop_binary' (/=) (/=) b x y prop_acc_eq - :: (Eq a, A.Eq a) + :: (Show a, Eq a, A.Eq a) => RunN -> Gen a -> Property @@ -94,7 +94,7 @@ prop_acc_binary (==) (A.==) runN x y prop_acc_neq - :: (Eq a, A.Eq a) + :: (Show a, Eq a, A.Eq a) => RunN -> Gen a -> Property diff --git a/test/Test/BigNum/FiniteBits.hs b/test/Test/BigNum/FiniteBits.hs --- a/test/Test/BigNum/FiniteBits.hs +++ b/test/Test/BigNum/FiniteBits.hs @@ -3,10 +3,10 @@ {-# LANGUAGE RankNTypes #-} -- | -- Module : Test.BigNum.FiniteBits --- Copyright : [2017] Trevor L. McDonell +-- Copyright : [2017..2020] Trevor L. McDonell -- License : BSD3 -- --- Maintainer : Trevor L. McDonell +-- Maintainer : Trevor L. McDonell -- Stability : experimental -- Portability : non-portable (GHC extensions) -- @@ -51,7 +51,7 @@ , testProperty "countTrailingZeros" $ prop_ctz a b ] - testAcc :: (Eq a, FiniteBits a, A.FiniteBits a, Show (ArgType a)) + testAcc :: (Show a, Eq a, FiniteBits a, A.FiniteBits a, Show (ArgType a)) => Gen a -> TestTree testAcc a = @@ -82,7 +82,7 @@ prop_unary' countTrailingZeros countTrailingZeros b x prop_acc_clz - :: (FiniteBits a, A.FiniteBits a) + :: (Show a, FiniteBits a, A.FiniteBits a) => RunN -> Gen a -> Property @@ -92,7 +92,7 @@ prop_acc_unary countLeadingZeros A.countLeadingZeros runN x prop_acc_ctz - :: (FiniteBits a, A.FiniteBits a) + :: (Show a, FiniteBits a, A.FiniteBits a) => RunN -> Gen a -> Property diff --git a/test/Test/BigNum/FromIntegral.hs b/test/Test/BigNum/FromIntegral.hs --- a/test/Test/BigNum/FromIntegral.hs +++ b/test/Test/BigNum/FromIntegral.hs @@ -5,10 +5,10 @@ {-# LANGUAGE ScopedTypeVariables #-} -- | -- Module : Test.BigNum.FromIntegral --- Copyright : [2017] Trevor L. McDonell +-- Copyright : [2017..2020] Trevor L. McDonell -- License : BSD3 -- --- Maintainer : Trevor L. McDonell +-- Maintainer : Trevor L. McDonell -- Stability : experimental -- Portability : non-portable (GHC extensions) -- @@ -75,7 +75,7 @@ ] where testElt - :: (Integral a, Num b, Eq b, A.Integral a, A.Num b, A.FromIntegral a b, Show (ArgType a), Show (ArgType b)) + :: (Show a, Show b, Integral a, Num b, Eq b, A.Integral a, A.Num b, A.FromIntegral a b, Show (ArgType a), Show (ArgType b)) => Gen a -> Proxy b -> TestTree @@ -84,7 +84,7 @@ prop_fromIntegral - :: forall a b. (Integral a, Num b, Eq b, A.Integral a, A.Num b, A.FromIntegral a b) + :: forall a b. (Show a, Show b, Integral a, Num b, Eq b, A.Integral a, A.Num b, A.FromIntegral a b) => RunN -> Gen a -> Proxy b diff --git a/test/Test/BigNum/Integral.hs b/test/Test/BigNum/Integral.hs --- a/test/Test/BigNum/Integral.hs +++ b/test/Test/BigNum/Integral.hs @@ -4,10 +4,10 @@ {-# LANGUAGE RankNTypes #-} -- | -- Module : Test.BigNum.Integral --- Copyright : [2017] Trevor L. McDonell +-- Copyright : [2017..2020] Trevor L. McDonell -- License : BSD3 -- --- Maintainer : Trevor L. McDonell +-- Maintainer : Trevor L. McDonell -- Stability : experimental -- Portability : non-portable (GHC extensions) -- @@ -56,7 +56,7 @@ , testProperty "toInteger" $ prop_toInteger a b ] - testAcc :: (Eq a, Integral a, A.Integral a, Show (ArgType a)) + testAcc :: (Show a, Eq a, Integral a, A.Integral a, Show (ArgType a)) => Gen a -> TestTree testAcc a = @@ -153,7 +153,7 @@ prop_unary' toInteger toInteger b x prop_acc_quot - :: (Integral a, A.Integral a) + :: (Show a, Integral a, A.Integral a) => RunN -> Gen a -> Property @@ -164,7 +164,7 @@ prop_acc_binary quot quot runN x y prop_acc_rem - :: (Integral a, A.Integral a) + :: (Show a, Integral a, A.Integral a) => RunN -> Gen a -> Property @@ -175,7 +175,7 @@ prop_acc_binary rem rem runN x y prop_acc_div - :: (Integral a, A.Integral a) + :: (Show a, Integral a, A.Integral a) => RunN -> Gen a -> Property @@ -186,7 +186,7 @@ prop_acc_binary div div runN x y prop_acc_mod - :: (Integral a, A.Integral a) + :: (Show a, Integral a, A.Integral a) => RunN -> Gen a -> Property @@ -197,7 +197,7 @@ prop_acc_binary mod mod runN x y prop_acc_quotRem - :: (Integral a, A.Integral a) + :: (Show a, Integral a, A.Integral a) => RunN -> Gen a -> Property @@ -208,7 +208,7 @@ prop_acc_binary quotRem (A.lift $$ quotRem) runN x y prop_acc_divMod - :: (Integral a, A.Integral a) + :: (Show a, Integral a, A.Integral a) => RunN -> Gen a -> Property diff --git a/test/Test/BigNum/Num.hs b/test/Test/BigNum/Num.hs --- a/test/Test/BigNum/Num.hs +++ b/test/Test/BigNum/Num.hs @@ -4,10 +4,10 @@ {-# LANGUAGE ScopedTypeVariables #-} -- | -- Module : Test.BigNum.Num --- Copyright : [2017] Trevor L. McDonell +-- Copyright : [2017..2020] Trevor L. McDonell -- License : BSD3 -- --- Maintainer : Trevor L. McDonell +-- Maintainer : Trevor L. McDonell -- Stability : experimental -- Portability : non-portable (GHC extensions) -- @@ -56,7 +56,7 @@ , testProperty "fromInteger" $ prop_fromInteger b ] - testAcc :: (Eq a, Num a, A.Num a, Show (ArgType a)) + testAcc :: (Show a, Eq a, Num a, A.Num a, Show (ArgType a)) => Gen a -> TestTree testAcc a = @@ -145,7 +145,7 @@ prop_acc_negate - :: (Num a, A.Num a, Eq a) + :: (Show a, Num a, A.Num a, Eq a) => RunN -> Gen a -> Property @@ -155,7 +155,7 @@ prop_acc_unary negate negate runN x prop_acc_abs - :: (Num a, A.Num a, Eq a) + :: (Show a, Num a, A.Num a, Eq a) => RunN -> Gen a -> Property @@ -165,7 +165,7 @@ prop_acc_unary abs abs runN x prop_acc_signum - :: (Num a, A.Num a, Eq a) + :: (Show a, Num a, A.Num a, Eq a) => RunN -> Gen a -> Property @@ -175,7 +175,7 @@ prop_acc_unary signum signum runN x prop_acc_add - :: (Num a, A.Num a, Eq a) + :: (Show a, Num a, A.Num a, Eq a) => RunN -> Gen a -> Property @@ -186,7 +186,7 @@ prop_acc_binary (+) (+) runN x y prop_acc_sub - :: (Num a, A.Num a, Eq a) + :: (Show a, Num a, A.Num a, Eq a) => RunN -> Gen a -> Property @@ -197,7 +197,7 @@ prop_acc_binary (-) (-) runN x y prop_acc_mul - :: (Num a, A.Num a, Eq a) + :: (Show a, Num a, A.Num a, Eq a) => RunN -> Gen a -> Property @@ -208,7 +208,7 @@ prop_acc_binary (*) (*) runN x y prop_acc_fromInteger - :: forall proxy a. (Num a, Eq a, A.Num a) + :: forall proxy a. (Show a, Num a, Eq a, A.Num a) => RunN -> proxy a -> Property diff --git a/test/Test/BigNum/Num2.hs b/test/Test/BigNum/Num2.hs --- a/test/Test/BigNum/Num2.hs +++ b/test/Test/BigNum/Num2.hs @@ -4,10 +4,10 @@ {-# LANGUAGE TypeFamilies #-} -- | -- Module : Test.BigNum.Num2 --- Copyright : [2017] Trevor L. McDonell +-- Copyright : [2017..2020] Trevor L. McDonell -- License : BSD3 -- --- Maintainer : Trevor L. McDonell +-- Maintainer : Trevor L. McDonell -- Stability : experimental -- Portability : non-portable (GHC extensions) -- @@ -42,7 +42,7 @@ , testElt i64 ] where - testElt :: ( Num2 e, Integral e, Show e, Show (ArgType e), FiniteBits (Unsigned e), Integral (Unsigned e) + testElt :: ( Show e, Num2 e, Integral e, Show e, Show (ArgType e), FiniteBits (Unsigned e), Integral (Unsigned e) , Num2 (Exp e), Elt e, Elt (Unsigned e), Lift Exp (Unsigned (Exp e)), Plain (Unsigned (Exp e)) ~ Unsigned e ) => Gen e -> TestTree @@ -57,7 +57,7 @@ prop_addWithCarry - :: (Num2 e, Integral e, Show e, FiniteBits (Unsigned e), Integral (Unsigned e)) + :: (Show e, Num2 e, Integral e, Show e, FiniteBits (Unsigned e), Integral (Unsigned e)) => Gen e -> Property prop_addWithCarry e = @@ -67,7 +67,7 @@ uncurry toInteger2 (addWithCarry x y) === toInteger x + toInteger y prop_mulWithCarry - :: (Num2 e, Integral e, Show e, FiniteBits (Unsigned e), Integral (Unsigned e)) + :: (Show e, Num2 e, Integral e, Show e, FiniteBits (Unsigned e), Integral (Unsigned e)) => Gen e -> Property prop_mulWithCarry e = @@ -77,7 +77,7 @@ uncurry toInteger2 (mulWithCarry x y) === toInteger x * toInteger y prop_acc_addWithCarry - :: ( Num2 (Exp e), Integral e, FiniteBits (Unsigned e), Integral (Unsigned e) + :: ( Show e, Num2 (Exp e), Integral e, FiniteBits (Unsigned e), Integral (Unsigned e) , Elt e, Elt (Unsigned e), Lift Exp (Unsigned (Exp e)), Plain (Unsigned (Exp e)) ~ Unsigned e ) => RunN -> Gen e @@ -89,7 +89,7 @@ uncurry toInteger2 (with_acc_binary runN (A.lift $$ addWithCarry) x y) === toInteger x + toInteger y prop_acc_mulWithCarry - :: ( Num2 (Exp e), Integral e, FiniteBits (Unsigned e), Integral (Unsigned e) + :: ( Show e, Num2 (Exp e), Integral e, FiniteBits (Unsigned e), Integral (Unsigned e) , Elt e, Elt (Unsigned e), Lift Exp (Unsigned (Exp e)), Plain (Unsigned (Exp e)) ~ Unsigned e ) => RunN -> Gen e diff --git a/test/Test/BigNum/Ord.hs b/test/Test/BigNum/Ord.hs --- a/test/Test/BigNum/Ord.hs +++ b/test/Test/BigNum/Ord.hs @@ -3,10 +3,10 @@ {-# LANGUAGE RankNTypes #-} -- | -- Module : Test.BigNum.Ord --- Copyright : [2017] Trevor L. McDonell +-- Copyright : [2017..2020] Trevor L. McDonell -- License : BSD3 -- --- Maintainer : Trevor L. McDonell +-- Maintainer : Trevor L. McDonell -- Stability : experimental -- Portability : non-portable (GHC extensions) -- @@ -49,7 +49,7 @@ [ testProperty "compare" $ prop_compare a b ] - testAcc :: (Ord a, A.Ord a, Show (ArgType a)) + testAcc :: (Show a, Ord a, A.Ord a, Show (ArgType a)) => Gen a -> TestTree testAcc a = @@ -73,7 +73,7 @@ prop_binary' compare compare b x y prop_acc_lt - :: (Ord a, A.Ord a) + :: (Show a, Ord a, A.Ord a) => RunN -> Gen a -> Property @@ -84,7 +84,7 @@ prop_acc_binary (<) (A.<) runN x y prop_acc_gt - :: (Ord a, A.Ord a) + :: (Show a, Ord a, A.Ord a) => RunN -> Gen a -> Property @@ -95,7 +95,7 @@ prop_acc_binary (>) (A.>) runN x y prop_acc_lte - :: (Ord a, A.Ord a) + :: (Show a, Ord a, A.Ord a) => RunN -> Gen a -> Property @@ -106,7 +106,7 @@ prop_acc_binary (<=) (A.<=) runN x y prop_acc_gte - :: (Ord a, A.Ord a) + :: (Show a, Ord a, A.Ord a) => RunN -> Gen a -> Property diff --git a/test/Test/BigNum/Real.hs b/test/Test/BigNum/Real.hs --- a/test/Test/BigNum/Real.hs +++ b/test/Test/BigNum/Real.hs @@ -2,10 +2,10 @@ {-# LANGUAGE FlexibleContexts #-} -- | -- Module : Test.BigNum.Real --- Copyright : [2017] Trevor L. McDonell +-- Copyright : [2017..2020] Trevor L. McDonell -- License : BSD3 -- --- Maintainer : Trevor L. McDonell +-- Maintainer : Trevor L. McDonell -- Stability : experimental -- Portability : non-portable (GHC extensions) -- diff --git a/test/Test/Iso.hs b/test/Test/Iso.hs --- a/test/Test/Iso.hs +++ b/test/Test/Iso.hs @@ -8,10 +8,10 @@ {-# LANGUAGE TypeSynonymInstances #-} -- | -- Module : Test.Iso --- Copyright : [2017] Trevor L. McDonell +-- Copyright : [2017..2020] Trevor L. McDonell -- License : BSD3 -- --- Maintainer : Trevor L. McDonell +-- Maintainer : Trevor L. McDonell -- Stability : experimental -- Portability : non-portable (GHC extensions) -- @@ -20,8 +20,7 @@ import Test.Base -import Data.Array.Accelerate.Array.Sugar -import Data.Array.Accelerate ( Exp ) +import Data.Array.Accelerate ( Exp, Elt, Scalar, fromFunction, indexArray, Z(..) ) import qualified Data.Array.Accelerate as A import Hedgehog @@ -39,7 +38,7 @@ instance Elt a => Iso a (Scalar a) where isoR x = fromFunction Z (const x) - isoL x = x ! Z + isoL x = indexArray x Z with_unary :: Iso a b => proxy b -> (b -> b) -> a -> a @@ -121,7 +120,7 @@ {-# INLINE prop_acc_unary #-} prop_acc_unary - :: (Elt a, Elt b, Eq b, MonadTest m) + :: (Elt a, Elt b, Eq b, Show b, MonadTest m) => (a -> b) -> (Exp a -> Exp b) -> RunN @@ -131,7 +130,7 @@ {-# INLINE prop_acc_binary #-} prop_acc_binary - :: (Elt a, Elt b, Elt c, Eq c, MonadTest m) + :: (Elt a, Elt b, Elt c, Eq c, Show c, MonadTest m) => (a -> b -> c) -> (Exp a -> Exp b -> Exp c) -> RunN diff --git a/test/Test/ShowType.hs b/test/Test/ShowType.hs --- a/test/Test/ShowType.hs +++ b/test/Test/ShowType.hs @@ -5,10 +5,10 @@ {-# LANGUAGE ScopedTypeVariables #-} -- | -- Module : Test.ShowType --- Copyright : [2017] Trevor L. McDonell +-- Copyright : [2017..2020] Trevor L. McDonell -- License : BSD3 -- --- Maintainer : Trevor L. McDonell +-- Maintainer : Trevor L. McDonell -- Stability : experimental -- Portability : non-portable (GHC extensions) -- diff --git a/test/Test/Types.hs b/test/Test/Types.hs --- a/test/Test/Types.hs +++ b/test/Test/Types.hs @@ -2,10 +2,10 @@ {-# LANGUAGE MultiParamTypeClasses #-} -- | -- Module : Test.Types --- Copyright : [2017] Trevor L. McDonell +-- Copyright : [2017..2020] Trevor L. McDonell -- License : BSD3 -- --- Maintainer : Trevor L. McDonell +-- Maintainer : Trevor L. McDonell -- Stability : experimental -- Portability : non-portable (GHC extensions) -- diff --git a/test/TestNative.hs b/test/TestNative.hs --- a/test/TestNative.hs +++ b/test/TestNative.hs @@ -1,9 +1,9 @@ -- | -- Module : TestNative --- Copyright : [2017] Trevor L. McDonell +-- Copyright : [2017..2020] Trevor L. McDonell -- License : BSD3 -- --- Maintainer : Trevor L. McDonell +-- Maintainer : Trevor L. McDonell -- Stability : experimental -- Portability : non-portable (GHC extensions) -- diff --git a/test/TestPTX.hs b/test/TestPTX.hs --- a/test/TestPTX.hs +++ b/test/TestPTX.hs @@ -1,9 +1,9 @@ -- | -- Module : TestPTX --- Copyright : [2017] Trevor L. McDonell +-- Copyright : [2017..2020] Trevor L. McDonell -- License : BSD3 -- --- Maintainer : Trevor L. McDonell +-- Maintainer : Trevor L. McDonell -- Stability : experimental -- Portability : non-portable (GHC extensions) --