{-# LANGUAGE MultiParamTypeClasses #-}
module LLVM.Extra.Arithmetic (
   -- * arithmetic: generalized and improved type inference
   Additive (zero, add, sub, neg), one, inc, dec,
   PseudoRing (mul), square,
   PseudoModule (scale),
   Field (fdiv),
   IntegerConstant(fromInteger'),
   RationalConstant(fromRational'),
   idiv, irem,
   fcmp, cmp, LLVM.CmpPredicate(..),
   and, or,
   Real (min, max, abs, signum),
   Fraction (truncate, fraction),
   signedFraction, addToPhase, incPhase,
   -- * pointer arithmetic
   advanceArrayElementPtr,
   -- * transcendental functions
   Algebraic (sqrt),
   Transcendental (pi, sin, cos, exp, log, pow),
   ) where

import LLVM.Extra.ArithmeticPrivate
   (cmp, fcmp, and, or,
    inc, dec, advanceArrayElementPtr, )

import qualified LLVM.Extra.Class as Class
import qualified LLVM.Extra.ScalarOrVector as SoV
import qualified LLVM.Core as LLVM
import LLVM.Core
   (CodeGenFunction, value, Value, ConstValue,
    IsType, IsInteger, IsFloating, IsArithmetic, IsFirstClass, )

import Control.Monad (liftM2, liftM3, )

import Prelude hiding
   (Real, and, or, sqrt, sin, cos, exp, log, abs, min, max, truncate, )



{- |
This and the following type classes
are intended for arithmetic operations on wrappers around LLVM types.
E.g. you might define a fixed point fraction type by

> newtype Fixed = Fixed Int32

and then use the same methods for floating point and fixed point arithmetic.

In contrast to the arithmetic methods in the @llvm@ wrapper,
in our methods the types of operands and result match.
Advantage: Type inference determines most of the types automatically.
Disadvantage: You cannot use constant values directly,
but you have to convert them all to 'Value'.
-}
class (Class.Zero a) => Additive a where
   zero :: a
   add :: a -> a -> CodeGenFunction r a
   sub :: a -> a -> CodeGenFunction r a
   neg :: a -> CodeGenFunction r a

instance (IsArithmetic a) => Additive (Value a) where
   zero = LLVM.value LLVM.zero
   add = LLVM.add
   sub = LLVM.sub
   neg = LLVM.neg

instance (IsArithmetic a) => Additive (ConstValue a) where
   zero = LLVM.zero
   add = LLVM.add
   sub = LLVM.sub
   neg = sub LLVM.zero

instance (Additive a, Additive b) => Additive (a,b) where
   zero = (zero, zero)
   add (x0,x1) (y0,y1) =
      liftM2 (,) (add x0 y0) (add x1 y1)
   sub (x0,x1) (y0,y1) =
      liftM2 (,) (sub x0 y0) (sub x1 y1)
   neg (x0,x1) =
      liftM2 (,) (neg x0)    (neg x1)

instance (Additive a, Additive b, Additive c) => Additive (a,b,c) where
   zero = (zero, zero, zero)
   add (x0,x1,x2) (y0,y1,y2) =
      liftM3 (,,) (add x0 y0) (add x1 y1) (add x2 y2)
   sub (x0,x1,x2) (y0,y1,y2) =
      liftM3 (,,) (sub x0 y0) (sub x1 y1) (sub x2 y2)
   neg (x0,x1,x2) =
      liftM3 (,,) (neg x0)    (neg x1)    (neg x2)


class (Additive a) => PseudoRing a where
   mul :: a -> a -> CodeGenFunction r a

instance (IsArithmetic v) => PseudoRing (Value v) where
   mul = LLVM.mul

instance (IsArithmetic v) => PseudoRing (ConstValue v) where
   mul = LLVM.mul


class (PseudoRing a, Additive v) => PseudoModule a v where
   scale :: a -> v -> CodeGenFunction r v

instance
   (SoV.PseudoModule a v) =>
      PseudoModule (Value a) (Value v) where
   scale = SoV.scale

instance
   (SoV.PseudoModule a v) =>
      PseudoModule (ConstValue a) (ConstValue v) where
   scale = SoV.scaleConst


class IntegerConstant a where
   fromInteger' :: Integer -> a

instance SoV.IntegerConstant a => IntegerConstant (ConstValue a) where
   fromInteger' = SoV.constFromInteger

instance SoV.IntegerConstant a => IntegerConstant (Value a) where
   fromInteger' = value . SoV.constFromInteger


one :: (IntegerConstant a) => a
one = fromInteger' 1


{-
more general alternative to 'inc',
but you may not like the resulting type constraints
-}
_inc ::
   (PseudoRing a, IntegerConstant a) =>
   a -> CodeGenFunction r a
_inc x = add x one

_dec ::
   (PseudoRing a, IntegerConstant a) =>
   a -> CodeGenFunction r a
_dec x = sub x one


square ::
   (PseudoRing a) =>
   a -> CodeGenFunction r a
square x = mul x x


class (PseudoRing a) => Field a where
   fdiv :: a -> a -> CodeGenFunction r a

instance (LLVM.IsFloating v) => Field (Value v) where
   fdiv = LLVM.fdiv

instance (LLVM.IsFloating v) => Field (ConstValue v) where
   fdiv = LLVM.fdiv


class (IntegerConstant a) => RationalConstant a where
   fromRational' :: Rational -> a

instance SoV.RationalConstant a => RationalConstant (ConstValue a) where
   fromRational' = SoV.constFromRational

instance SoV.RationalConstant a => RationalConstant (Value a) where
   fromRational' = value . SoV.constFromRational



idiv ::
   (IsInteger a) =>
   Value a -> Value a -> CodeGenFunction r (Value a)
idiv = LLVM.idiv

irem ::
   (IsInteger a) =>
   Value a -> Value a -> CodeGenFunction r (Value a)
irem = LLVM.irem



class (Additive a) => Real a where
   min :: a -> a -> CodeGenFunction r a
   max :: a -> a -> CodeGenFunction r a
   abs :: a -> CodeGenFunction r a
   signum :: a -> CodeGenFunction r a

instance (SoV.Real a) => Real (Value a) where
   min = SoV.min
   max = SoV.max
   abs = SoV.abs
   signum = SoV.signum


class (Real a) => Fraction a where
   truncate :: a -> CodeGenFunction r a
   fraction :: a -> CodeGenFunction r a

instance (SoV.Fraction a) => Fraction (Value a) where
   truncate = SoV.truncate
   fraction = SoV.fraction

signedFraction ::
   (Fraction a) =>
   a -> CodeGenFunction r a
signedFraction x =
   sub x =<< truncate x

addToPhase ::
   (Fraction a) =>
   a -> a -> CodeGenFunction r a
addToPhase d p =
   fraction =<< add d p

{- |
both increment and phase must be non-negative
-}
incPhase ::
   (Fraction a) =>
   a -> a -> CodeGenFunction r a
incPhase d p =
   signedFraction =<< add d p



valueTypeName ::
   (IsType a) =>
   Value a -> String
valueTypeName =
   LLVM.intrinsicTypeName . (undefined :: Value a -> a)


callIntrinsic1 ::
   (IsFirstClass a) =>
   String -> Value a -> CodeGenFunction r (Value a)
callIntrinsic1 fn x = do
   op <- LLVM.externFunction ("llvm." ++ fn ++ "." ++ valueTypeName x)
   LLVM.call op x >>= addReadNone

callIntrinsic2 ::
   (IsFirstClass a) =>
   String -> Value a -> Value a -> CodeGenFunction r (Value a)
callIntrinsic2 fn x y = do
   op <- LLVM.externFunction ("llvm." ++ fn ++ "." ++ valueTypeName x)
   LLVM.call op x y >>= addReadNone


{-
If we add the attribute, then LLVM-2.8 complains:

$ ./dist/build/synthi-llvm-test/synthi-llvm-test
Attribute readnone only applies to the function!
  %97 = call readnone float @llvm.sin.f32(float %96)
Attribute readnone only applies to the function!
  %99 = call readnone float @llvm.exp.f32(float %98)
Attribute readnone only applies to the function!
  %102 = call readnone float @llvm.cos.f32(float %101)
Broken module found, compilation aborted!
Stack dump:
0.      Running pass 'Function Pass Manager' on module '_module'.
1.      Running pass 'Module Verifier' on function '@fillsignal'
make: *** [test] Abgebrochen
-}
addReadNone :: Value a -> CodeGenFunction r (Value a)
addReadNone x = do
--   LLVM.addAttributes x 0 [LLVM.ReadNoneAttribute]
   return x


class Field a => Algebraic a where
   sqrt :: a -> CodeGenFunction r a

instance (IsFloating a) => Algebraic (Value a) where
   sqrt = callIntrinsic1 "sqrt"


class Algebraic a => Transcendental a where
   pi :: CodeGenFunction r a
   sin, cos, exp, log :: a -> CodeGenFunction r a
   pow :: a -> a -> CodeGenFunction r a

instance (IsFloating a, SoV.TranscendentalConstant a) => Transcendental (Value a) where
   pi = return $ value SoV.constPi
   sin = callIntrinsic1 "sin"
   cos = callIntrinsic1 "cos"
   exp = callIntrinsic1 "exp"
   log = callIntrinsic1 "log"
   pow = callIntrinsic2 "pow"