<|start_filename|>sbcl-opt/x86-64-vm.lisp<|end_filename|>
;;;; x86-64-vm.lisp -- VOP definitions SBCL

#+sbcl
(cl:in-package :sb-vm)

#+(and sbcl x86-64) (progn

(define-vop (%check-bound)
  (:translate nibbles::%check-bound)
  (:policy :fast-safe)
  (:args (array :scs (descriptor-reg))
         (bound :scs (any-reg))
         (index :scs (any-reg)))
  (:arg-types simple-array-unsigned-byte-8 positive-fixnum tagged-num
              (:constant (member 2 4 8 16)))
  (:info offset)
  (:temporary (:sc any-reg) temp)
  (:results (result :scs (any-reg)))
  (:result-types positive-fixnum)
  (:vop-var vop)
  (:generator 5
    (let ((error (generate-error-code vop 'invalid-array-index-error
                                      array bound index)))
      ;; We want to check the conditions:
      ;;
      ;; 0 <= INDEX
      ;; INDEX < BOUND
      ;; 0 <= INDEX + OFFSET
      ;; (INDEX + OFFSET) < BOUND
      ;;
      ;; We can do this naively with two unsigned checks:
      ;;
      ;; INDEX <_u BOUND
      ;; INDEX + OFFSET <_u BOUND
      ;;
      ;; If INDEX + OFFSET <_u BOUND, though, INDEX must be less than
      ;; BOUND.  We *do* need to check for 0 <= INDEX, but that has
      ;; already been assured by higher-level machinery.
      (inst lea temp (ea (fixnumize offset) nil index))
      (inst cmp temp bound)
      (inst jmp :a error)
      (move result index))))

#.(flet ((frob (bitsize setterp signedp big-endian-p)
           (let* ((name (funcall (if setterp
                                     #'nibbles::byte-set-fun-name
                                     #'nibbles::byte-ref-fun-name)
                                 bitsize signedp big-endian-p))
                  (internal-name (nibbles::internalify name))
                  (operand-size (ecase bitsize
                                  (16 :word)
                                  (32 :dword)
                                  (64 :qword)))
                  (ref-mov-insn (ecase bitsize
                                  (16
                                   (if big-endian-p
                                       'movzx
                                       (if signedp 'movsx 'movzx)))
                                  (32
                                   (if big-endian-p
                                       'mov
                                       (if signedp 'movsxd 'movzxd)))
                                   (64 'mov)))
                  (result-sc (if signedp 'signed-reg 'unsigned-reg))
                  (result-type (if signedp 'signed-num 'unsigned-num)))
             (flet ((movx (insn dest source source-size)
                      (cond ((eq insn 'mov)
                             `(inst ,insn ,dest ,source))
                            ;; (movzx (:dword :qword) dest source) is
                            ;; no longer allowed on SBCL > 2.1.4.134
                            ;; but older versions already supported
                            ;; this new spelling.
                            ((and (member insn '(movzx movzxd))
                                  (eq source-size :dword))
                             `(inst mov :dword ,dest ,source))
                            (t
                             `(inst ,(case insn (movsxd 'movsx) (movzxd 'movzx) (t insn))
                                    '(,source-size :qword) ,dest ,source))))
                    (swap-tn-inst-form (tn-name)
                      (if (= bitsize 16)
                          `(inst rol ,operand-size ,tn-name 8)
                          ;; The '(bswap :dword r)' notation is only
                          ;; supported on SBCL > 1.5.9.
                          (if (ignore-errors (sb-ext:assert-version->= 1 5 9 17) t)
                              `(inst bswap ,operand-size ,tn-name)
                              `(inst bswap (sb-vm::reg-in-size ,tn-name ,operand-size))))))
               `(define-vop (,name)
                  (:translate ,internal-name)
                  (:policy :fast-safe)
                  (:args (vector :scs (descriptor-reg))
                         (index :scs (immediate unsigned-reg))
                         ,@(when setterp
                             `((value* :scs (,result-sc) :target result))))
                  (:arg-types simple-array-unsigned-byte-8
                              positive-fixnum
                              ,@(when setterp
                                  `(,result-type)))
                  ,@(when (and setterp big-endian-p)
                      `((:temporary (:sc unsigned-reg
                                     :from (:load 0)
                                     :to (:result 0)) temp)))
                  (:results (result :scs (,result-sc)))
                  (:result-types ,result-type)
                  (:generator 3
                    (let* ((base-disp (- (* vector-data-offset n-word-bytes)
                                         other-pointer-lowtag))
                           (memref (sc-case index
                                     (immediate
                                      (ea (+ (tn-value index) base-disp) vector))
                                     (t
                                      (ea base-disp vector index)))))
                      ,@(when (and setterp big-endian-p)
                          `((inst mov temp value*)
                            ,(swap-tn-inst-form 'temp)))
                      ,(if setterp
                           `(inst mov ,operand-size memref ,(if big-endian-p
                                                                'temp
                                                                'value*))
                           (movx ref-mov-insn 'result 'memref operand-size))
                      ,@(if setterp
                            '((move result value*))
                            (when big-endian-p
                              `(,(swap-tn-inst-form 'result)
                                ,(when (and (/= bitsize 64) signedp)
                                   (movx 'movsx 'result 'result operand-size))))))))))))
    (loop for i from 0 upto #b10111
          for bitsize = (ecase (ldb (byte 2 3) i)
                          (0 16)
                          (1 32)
                          (2 64))
          for setterp = (logbitp 2 i)
          for signedp = (logbitp 1 i)
          for big-endian-p = (logbitp 0 i)
          collect (frob bitsize setterp signedp big-endian-p) into forms
          finally (return `(progn ,@forms))))

);#+(and sbcl x86-64)


<|start_filename|>nibbles.asd<|end_filename|>
; -*- mode: lisp -*-

(cl:defpackage :nibbles-system
  (:use :cl))

(cl:in-package :nibbles-system)

(defclass nibbles-source-file (asdf:cl-source-file) ())
(defclass txt-file (asdf:doc-file) ((type :initform "txt")))
(defclass css-file (asdf:doc-file) ((type :initform "css")))

(defmethod asdf:perform :around ((op asdf:compile-op) (c nibbles-source-file))
  (let ((*print-base* 10)               ; INTERN'ing FORMAT'd symbols
        (*print-case* :upcase)
        #+sbcl (sb-ext:*inline-expansion-limit* (max sb-ext:*inline-expansion-limit* 1000))
        #+cmu (ext:*inline-expansion-limit* (max ext:*inline-expansion-limit* 1000)))
    (call-next-method)))

(defmethod asdf:perform :around ((op asdf:load-op) (c nibbles-source-file))
  (call-next-method))

(asdf:defsystem "nibbles"
  :version "0.13"
  :author "<NAME> <<EMAIL>>"
  :maintainer "Sharp Lispers <<EMAIL>>"
  :description "A library for accessing octet-addressed blocks of data in big- and little-endian orders"
  :license "BSD-style (http://opensource.org/licenses/BSD-3-Clause)"
  :default-component-class nibbles-source-file
  :components ((:static-file "README.md")
               (:static-file "LICENSE")
               (:static-file "NEWS")
               (:file "package")
               (:file "types" :depends-on ("package"))
               (:file "macro-utils" :depends-on ("package"))
               (:file "vectors" :depends-on ("types" "macro-utils"))
               (:file "streams" :depends-on ("vectors"))
               (:module "doc"
                        :components ((:html-file "index")
                                     (:txt-file "nibbles-doc")
                                     (:css-file "style")))
               (:module "sbcl-opt"
                        :depends-on ("package" "macro-utils")
                        :components ((:file "fndb")
                                     (:file "nib-tran" :depends-on ("fndb"))
                                     (:file "x86-vm" :depends-on ("fndb"))
                                     (:file "x86-64-vm" :depends-on ("fndb")))))
  :in-order-to ((asdf:test-op (asdf:test-op "nibbles/tests")))
  :perform (asdf:prepare-op (component operation)
             ;; nibbles uses SBCL's assembler on x86 and x86-64. The
             ;; interface of the assembler with SBCL version 1.4.10.
             #+(and sbcl (or x86 x86-64)) (sb-ext:assert-version->= 1 4 10)))

(asdf:defsystem "nibbles/tests"
  :depends-on ("nibbles" "rt")
  :version "0.1"
  :author "<NAME> <<EMAIL>>"
  :maintainer "<NAME> <<EMAIL>>"
  :components ((:file "tests"))
  :perform (asdf:test-op (operation component)
             (or (uiop:symbol-call '#:rtest '#:do-tests)
                 (error "TEST-OP failed for NIBBLES-TESTS"))))
