x64-64 prefetch intrinsic for sbcl

prefetch.lisp

(sb-c:defknown prefetch ((member :nta :t0 :t1 :t2)
                         sb-sys:system-area-pointer sb-vm:signed-word
                         (member 2 4 8 16)
                         fixnum)
    (values &optional)
    (sb-c:any sb-c:always-translatable) :overwrite-fndb-silently t)

(sb-c:define-vop (prefetch)
  (:translate prefetch)
  (:policy :fast-safe)
  (:args (base :scs (sb-vm::sap-reg))
         (index :scs (sb-vm::any-reg)))
  (:arg-types (:constant (member :nta :t0 :t1 :t2))
              sb-sys:system-area-pointer
              (:constant sb-vm:signed-word)
              (:constant (member . #.(loop for i below 4
                                            collect (ash 1 (+ i sb-vm:n-fixnum-tag-bits)))))
              fixnum)
  (:results)
  (:info type disp stride)
  (:generator 1
    (sb-assem:inst prefetch type
                   (sb-x86-64-asm::make-ea :byte :base base
                                           :index index
                                           :scale (ash stride
                                                       (- sb-vm:n-fixnum-tag-bits))
                                           :disp disp))))

(defun prefetch (type base displacement stride index)
  (declare (ignore type)  ;; always do t0
           (type system-area-pointer base)
           (type (signed-byte #.sb-vm:n-word-bits) displacement)
           (type (member (2 4 8 16) displacement))
           (type fixnum index))
  (assert (zerop displacement))
  (ecase stride
    (2
     (prefetch :t0 base 0 2 index))
    (4
     (prefetch :t0 base 0 4 index))
    (8
     (prefetch :t0 base 0 8 index))
    (16
     (prefetch :t0 base 0 16 index))))