(in-package #:sb-simd-internals)

;;; Primitives with a :NONE encoding do not define a VOP.  Instead, we
;;; define a fake VOP - a regular function that has the name of the VOP
;;; that would have been generated if the encoding wasn't :NONE.  Fake VOPs
;;; are useful for defining instructions that we would like to have in the
;;; instruction set, and that can be expressed easily in terms of the other
;;; VOPs.

(defmacro define-fake-vop (name lambda-list &body body)
  (with-accessors ((vop instruction-record-vop)
                   (result-records instruction-record-result-records)
                   (argument-records instruction-record-argument-records)
                   (instruction-set instruction-record-instruction-set))
      (find-function-record name)
    (assert (= (length lambda-list)
               (length argument-records)))
    (assert (null (intersection lambda-list lambda-list-keywords)))
    (when (instruction-set-available-p instruction-set)
      `(define-inline ,vop ,lambda-list
         (declare (optimize (safety 0) (debug 0)))
         (declare
          ,@(loop for argument-record in argument-records
                  for argument in lambda-list
                  collect `(type ,(value-record-name argument-record) ,argument)))
         (the (values ,@(mapcar #'value-record-name result-records) &optional)
              (progn ,@body))))))

(defmacro define-trivial-fake-vop (name operator &key key result-key)
  (let* ((record (find-function-record name))
         (arity (length (instruction-record-argument-records record)))
         (args (prefixed-symbols "ARG" arity)))
    (assert (= 1 (length (instruction-record-result-records record))))
    (flet ((wrap (key expr)
             (if (null key) expr `(,key ,expr))))
      `(define-fake-vop ,name ,args
         ,(wrap result-key `(,operator ,@(loop for arg in args collect (wrap key arg))))))))

(in-package #:sb-simd)

(macrolet ((define-u64-packer (name scalar-record-name)
             (with-accessors ((type value-record-name)
                              (bits value-record-bits))
                 (find-value-record scalar-record-name)
               (let ((args (prefixed-symbols "ARG" (the integer (/ 64 bits)))))
                 `(define-fake-vop ,name ,args
                    (logior
                     ,@(loop for arg in args
                             for position from 0 by bits
                             collect `(dpb ,arg (byte ,bits ,position) 0))))))))
  (define-u64-packer u64-from-u8s u8)
  (define-u64-packer u64-from-u16s u16)
  (define-u64-packer u64-from-u32s u32)
  (define-u64-packer u64-from-s8s s8)
  (define-u64-packer u64-from-s16s s16)
  (define-u64-packer u64-from-s32s s32)
  (define-u64-packer u64-from-s64 s64))

(define-fake-vop s32-from-f32 (x)
  (multiple-value-bind (significant exponent sign)
      (integer-decode-float x)
    (let* ((abs (* significant (expt (float-radix x) exponent))))
      (if (minusp sign)
          (- (min abs (expt 2 31)))
          (min abs (1- (expt 2 31)))))))

(define-fake-vop s32-from-f64 (x)
  (multiple-value-bind (significant exponent sign)
      (integer-decode-float x)
    (let* ((abs (* significant (expt (float-radix x) exponent))))
      (if (minusp sign)
          (- (min abs (expt 2 31)))
          (min abs (1- (expt 2 31)))))))

(macrolet ((define-u64-unpacker (name scalar-record-name)
             (with-accessors ((type value-record-name)
                              (bits value-record-bits))
                 (find-value-record scalar-record-name)
               `(define-fake-vop ,name (x)
                  (values
                   ,@ (loop repeat (/ 64 bits)
                            for position from 0 by bits
                            collect
                            (if (subtypep type 'unsigned-byte)
                                `(ldb (byte ,bits ,position) x)
                                `(- (mod (+ (ldb (byte ,bits ,position) x)
                                            ,(expt 2 (1- bits)))
                                         ,(expt 2 bits))
                                    ,(expt 2 (1- bits))))))))))

  (define-u64-unpacker u8s-from-u64 u8)
  (define-u64-unpacker u16s-from-u64 u16)
  (define-u64-unpacker u32s-from-u64 u32)
  (define-u64-unpacker s8s-from-u64 s8)
  (define-u64-unpacker s16s-from-u64 s16)
  (define-u64-unpacker s32s-from-u64 s32)
  (define-u64-unpacker s64-from-u64 s64))

(macrolet ((define-deboolifier (name true false)
             `(define-inline ,name (expr) (if expr ,true ,false))))
  (define-deboolifier u8-from-boolean  +u8-true+  +u8-false+)
  (define-deboolifier u16-from-boolean +u16-true+ +u16-false+)
  (define-deboolifier u32-from-boolean +u32-true+ +u32-false+)
  (define-deboolifier u64-from-boolean +u64-true+ +u64-false+))

(defun u16-odd-bits (x)
  (declare (type (unsigned-byte 16) x))
  (setf x (logand (ash x -1) #x5555))
  (setf x (logand (logior (ash x -1) x) #x3333))
  (setf x (logand (logior (ash x -2) x) #x0F0F))
  (setf x (logand (logior (ash x -4) x) #x00FF))
  x)

(defun u32-odd-bits (x)
  (declare (type (unsigned-byte 32) x))
  (setf x (logand (ash x -1) #x55555555))
  (setf x (logand (logior (ash x -1) x) #x33333333))
  (setf x (logand (logior (ash x -2) x) #x0F0F0F0F))
  (setf x (logand (logior (ash x -4) x) #x00FF00FF))
  (setf x (logand (logior (ash x -8) x) #x0000FFFF))
  x)

;;; f32

(define-fake-vop f32-reciprocal (x)
  (/ x))

(define-fake-vop f32-rsqrt (x)
  (/ (sqrt x)))

(define-fake-vop f32-if (mask a b)
  (if (logbitp 31 mask) a b))

(macrolet ((def (name op &rest keywords) `(define-trivial-fake-vop ,name ,op ,@keywords)))
  (def two-arg-f32-and logand :key sb-kernel:single-float-bits :result-key sb-kernel:make-single-float)
  (def two-arg-f32-or logior :key sb-kernel:single-float-bits :result-key sb-kernel:make-single-float)
  (def two-arg-f32-xor logxor :key sb-kernel:single-float-bits :result-key sb-kernel:make-single-float)
  (def f32-andc1 logandc1 :key sb-kernel:single-float-bits :result-key sb-kernel:make-single-float)
  (def f32-not lognot :key sb-kernel:single-float-bits :result-key sb-kernel:make-single-float)
  (def two-arg-f32-min min)
  (def two-arg-f32-max max)
  (def two-arg-f32+ +)
  (def two-arg-f32- -)
  (def two-arg-f32* *)
  (def two-arg-f32/ /)
  (def f32-sqrt sqrt)
  (def two-arg-f32=  =  :result-key u32-from-boolean)
  (def two-arg-f32/= /= :result-key u32-from-boolean)
  (def two-arg-f32<  <  :result-key u32-from-boolean)
  (def two-arg-f32<= <= :result-key u32-from-boolean)
  (def two-arg-f32>  >  :result-key u32-from-boolean)
  (def two-arg-f32>= >= :result-key u32-from-boolean))

;;; f64

(define-fake-vop f64-reciprocal (x)
  (/ x))

(define-fake-vop f64-rsqrt (x)
  (/ (sqrt x)))

(define-fake-vop f64-if (mask a b)
  (if (logbitp 63 mask) a b))

(macrolet ((def (name logical-operation)
             (let* ((record (find-function-record name))
                    (arity (length (instruction-record-argument-records record)))
                    (args (prefixed-symbols "ARG" arity)))
               `(define-fake-vop ,name ,args
                  (let ((bits
                          (,logical-operation
                           ,@(loop for arg in args
                                   collect `(sb-kernel:double-float-bits ,arg)))))
                    (sb-kernel:make-double-float
                     (ash bits -32)
                     (ldb (byte 32 0) bits)))))))
  (def two-arg-f64-and logand)
  (def two-arg-f64-or logior)
  (def two-arg-f64-xor logxor)
  (def f64-andc1 logandc1)
  (def f64-not lognot))

(macrolet ((def (name op &rest keywords) `(define-trivial-fake-vop ,name ,op ,@keywords)))
  (def two-arg-f64-min min)
  (def two-arg-f64-max max)
  (def two-arg-f64+ +)
  (def two-arg-f64- -)
  (def two-arg-f64* *)
  (def two-arg-f64/ /)
  (def f64-sqrt sqrt)
  (def two-arg-f64=  =  :result-key u64-from-boolean)
  (def two-arg-f64/= /= :result-key u64-from-boolean)
  (def two-arg-f64<  <  :result-key u64-from-boolean)
  (def two-arg-f64<= <= :result-key u64-from-boolean)
  (def two-arg-f64>  >  :result-key u64-from-boolean)
  (def two-arg-f64>= >= :result-key u64-from-boolean))

;;; integer operations

;;; In contrast to the floating-point conditional selection operations,
;;; those for integers always operate with byte granularity.
(macrolet ((def (name maskbits)
             `(define-fake-vop ,name (mask a b)
                (logior
                 ,@(loop for offset from 0 by 8 below maskbits
                         collect
                         `(if (logbitp ,(+ offset 7) mask)
                              (mask-field (byte 8 ,offset) a)
                              (mask-field (byte 8 ,offset) b)))))))
  (def  u8-if  8)
  (def u16-if 16)
  (def u32-if 32)
  (def u64-if 64))

(macrolet ((def (name bits u-if)
             `(define-fake-vop ,name (mask a b)
                (let ((u (,u-if mask (dpb a (byte ,bits 0) 0) (dpb b (byte ,bits 0) 0))))
                  (- (mod (+ (ldb (byte ,bits 0) u) ,(expt 2 (1- bits)))
                          ,(expt 2 bits))
                     ,(expt 2 (1- bits)))))))
  (def  s8-if  8 %u8-if)
  (def s16-if 16 %u16-if)
  (def s32-if 32 %u32-if)
  (def s64-if 64 %u64-if))

(macrolet ((def (name bits)
             `(define-inline ,name (integer)
                (declare (integer integer))
                (mod integer ,(expt 2 bits)))))
  (def  u8-wrap  8)
  (def u16-wrap 16)
  (def u32-wrap 32)
  (def u64-wrap 64))

(macrolet ((def (name bits)
             (let ((offset (expt 2 (1- bits))))
               `(define-inline ,name (integer)
                  (declare (integer integer))
                  (- (mod (+ integer ,offset) ,(expt 2 bits))
                     ,offset)))))
  (def  s8-wrap  8)
  (def s16-wrap 16)
  (def s32-wrap 32)
  (def s64-wrap 64))

(macrolet ((def (name op &rest keywords) `(define-trivial-fake-vop ,name ,op ,@keywords)))
  ;; u8
  (def two-arg-u8-and logand)
  (def two-arg-u8-or logior)
  (def two-arg-u8-xor logxor)
  (def two-arg-u8-max max)
  (def two-arg-u8-min min)
  (def two-arg-u8+ + :result-key u8-wrap)
  (def two-arg-u8- - :result-key u8-wrap)
  (def two-arg-u8=  =  :result-key u8-from-boolean)
  (def two-arg-u8/= /= :result-key u8-from-boolean)
  (def two-arg-u8<  <  :result-key u8-from-boolean)
  (def two-arg-u8<= <= :result-key u8-from-boolean)
  (def two-arg-u8>  >  :result-key u8-from-boolean)
  (def two-arg-u8>= >= :result-key u8-from-boolean)
  (def u8-andc1 logandc1)
  (def u8-not lognot :result-key u8-wrap)
  ;; u16
  (def two-arg-u16-and logand)
  (def two-arg-u16-or logior)
  (def two-arg-u16-xor logxor)
  (def two-arg-u16-max max)
  (def two-arg-u16-min min)
  (def two-arg-u16+ + :result-key u16-wrap)
  (def two-arg-u16- - :result-key u16-wrap)
  (def two-arg-u16=  =  :result-key u16-from-boolean)
  (def two-arg-u16/= /= :result-key u16-from-boolean)
  (def two-arg-u16<  <  :result-key u16-from-boolean)
  (def two-arg-u16<= <= :result-key u16-from-boolean)
  (def two-arg-u16>  >  :result-key u16-from-boolean)
  (def two-arg-u16>= >= :result-key u16-from-boolean)
  (def u16-andc1 logandc1)
  (def u16-not lognot :result-key u16-wrap)
  ;; u32
  (def two-arg-u32-and logand)
  (def two-arg-u32-or logior)
  (def two-arg-u32-xor logxor)
  (def two-arg-u32-max max)
  (def two-arg-u32-min min)
  (def two-arg-u32+ + :result-key u32-wrap)
  (def two-arg-u32- - :result-key u32-wrap)
  (def two-arg-u32=  =  :result-key u32-from-boolean)
  (def two-arg-u32/= /= :result-key u32-from-boolean)
  (def two-arg-u32<  <  :result-key u32-from-boolean)
  (def two-arg-u32<= <= :result-key u32-from-boolean)
  (def two-arg-u32>  >  :result-key u32-from-boolean)
  (def two-arg-u32>= >= :result-key u32-from-boolean)
  (def u32-andc1 logandc1)
  (def u32-not lognot :result-key u32-wrap)
  ;; u64
  (def two-arg-u64-and logand)
  (def two-arg-u64-or logior)
  (def two-arg-u64-xor logxor)
  (def two-arg-u64-max max)
  (def two-arg-u64-min min)
  (def two-arg-u64+ + :result-key u64-wrap)
  (def two-arg-u64- - :result-key u64-wrap)
  (def two-arg-u64=  =  :result-key u64-from-boolean)
  (def two-arg-u64/= /= :result-key u64-from-boolean)
  (def two-arg-u64<  <  :result-key u64-from-boolean)
  (def two-arg-u64<= <= :result-key u64-from-boolean)
  (def two-arg-u64>  >  :result-key u64-from-boolean)
  (def two-arg-u64>= >= :result-key u64-from-boolean)
  (def u64-andc1 logandc1)
  (def u64-not lognot :result-key u64-wrap)
  ;; s8
  (def two-arg-s8-and logand)
  (def two-arg-s8-or logior)
  (def two-arg-s8-xor logxor)
  (def two-arg-s8-max max)
  (def two-arg-s8-min min)
  (def two-arg-s8+ + :result-key s8-wrap)
  (def two-arg-s8- - :result-key s8-wrap)
  (def two-arg-s8=  =  :result-key u8-from-boolean)
  (def two-arg-s8/= /= :result-key u8-from-boolean)
  (def two-arg-s8<  <  :result-key u8-from-boolean)
  (def two-arg-s8<= <= :result-key u8-from-boolean)
  (def two-arg-s8>  >  :result-key u8-from-boolean)
  (def two-arg-s8>= >= :result-key u8-from-boolean)
  (def s8-andc1 logandc1)
  (def s8-not lognot :result-key s8-wrap)
  ;; s16
  (def two-arg-s16-and logand)
  (def two-arg-s16-or logior)
  (def two-arg-s16-xor logxor)
  (def two-arg-s16-max max)
  (def two-arg-s16-min min)
  (def two-arg-s16+ + :result-key s16-wrap)
  (def two-arg-s16- - :result-key s16-wrap)
  (def two-arg-s16=  =  :result-key u16-from-boolean)
  (def two-arg-s16/= /= :result-key u16-from-boolean)
  (def two-arg-s16<  <  :result-key u16-from-boolean)
  (def two-arg-s16<= <= :result-key u16-from-boolean)
  (def two-arg-s16>  >  :result-key u16-from-boolean)
  (def two-arg-s16>= >= :result-key u16-from-boolean)
  (def s16-andc1 logandc1)
  (def s16-not lognot :result-key s16-wrap)
  ;; s32
  (def two-arg-s32-and logand)
  (def two-arg-s32-or logior)
  (def two-arg-s32-xor logxor)
  (def two-arg-s32-max max)
  (def two-arg-s32-min min)
  (def two-arg-s32+ + :result-key s32-wrap)
  (def two-arg-s32- - :result-key s32-wrap)
  (def two-arg-s32=  =  :result-key u32-from-boolean)
  (def two-arg-s32/= /= :result-key u32-from-boolean)
  (def two-arg-s32<  <  :result-key u32-from-boolean)
  (def two-arg-s32<= <= :result-key u32-from-boolean)
  (def two-arg-s32>  >  :result-key u32-from-boolean)
  (def two-arg-s32>= >= :result-key u32-from-boolean)
  (def s32-andc1 logandc1)
  (def s32-not lognot :result-key s32-wrap)
  ;; s64
  (def two-arg-s64-and logand)
  (def two-arg-s64-or logior)
  (def two-arg-s64-xor logxor)
  (def two-arg-s64-max max)
  (def two-arg-s64-min min)
  (def two-arg-s64+ + :result-key s64-wrap)
  (def two-arg-s64- - :result-key s64-wrap)
  (def two-arg-s64=  =  :result-key u64-from-boolean)
  (def two-arg-s64/= /= :result-key u64-from-boolean)
  (def two-arg-s64<  <  :result-key u64-from-boolean)
  (def two-arg-s64<= <= :result-key u64-from-boolean)
  (def two-arg-s64>  >  :result-key u64-from-boolean)
  (def two-arg-s64>= >= :result-key u64-from-boolean)
  (def s64-andc1 logandc1)
  (def s64-not lognot :result-key s64-wrap))
