macros.lisp

开源跨平台Lisp编译器

;;;; a bunch of handy macros for the x86

;;;; This software is part of the SBCL system. See the README file for
;;;; more information.
;;;;
;;;; This software is derived from the CMU CL system, which was
;;;; written at Carnegie Mellon University and released into the
;;;; public domain. The software is in the public domain and is
;;;; provided with absolutely no warranty. See the COPYING and CREDITS
;;;; files for more information.

(in-package "SB!VM")

;;;; instruction-like macros

(defmacro move (dst src)
  #!+sb-doc
  "Move SRC into DST unless they are location=."
  (once-only ((n-dst dst)
              (n-src src))
    `(unless (location= ,n-dst ,n-src)
       (sc-case ,n-dst
         (single-reg
          (inst movss ,n-dst ,n-src))
         (double-reg
          (inst movsd ,n-dst ,n-src))
         (t
          (inst mov ,n-dst ,n-src))))))

(defmacro make-ea-for-object-slot (ptr slot lowtag)
  `(make-ea :qword :base ,ptr :disp (- (* ,slot n-word-bytes) ,lowtag)))
(defmacro make-ea-for-object-slot-half (ptr slot lowtag)
  `(make-ea :dword :base ,ptr :disp (- (* ,slot n-word-bytes) ,lowtag)))

(defmacro loadw (value ptr &optional (slot 0) (lowtag 0))
  `(inst mov ,value (make-ea-for-object-slot ,ptr ,slot ,lowtag)))

(defmacro storew (value ptr &optional (slot 0) (lowtag 0))
  (once-only ((value value))
    `(cond ((and (integerp ,value)
                 (not (typep ,value '(signed-byte 32))))
            (multiple-value-bind (lo hi) (dwords-for-quad ,value)
              (inst mov (make-ea-for-object-slot-half
                         ,ptr ,slot ,lowtag) lo)
              (inst mov (make-ea-for-object-slot-half
                         ,ptr (+ ,slot 1/2) ,lowtag) hi)))
           (t
            (inst mov (make-ea-for-object-slot ,ptr ,slot ,lowtag) ,value)))))

(defmacro pushw (ptr &optional (slot 0) (lowtag 0))
  `(inst push (make-ea-for-object-slot ,ptr ,slot ,lowtag)))

(defmacro popw (ptr &optional (slot 0) (lowtag 0))
  `(inst pop (make-ea-for-object-slot ,ptr ,slot ,lowtag)))

;;;; macros to generate useful values

(defmacro load-symbol (reg symbol)
  `(inst mov ,reg (+ nil-value (static-symbol-offset ,symbol))))

(defmacro make-ea-for-symbol-value (symbol)
  `(make-ea :qword
    :disp (+ nil-value
           (static-symbol-offset ',symbol)
           (ash symbol-value-slot word-shift)
           (- other-pointer-lowtag))))

(defmacro load-symbol-value (reg symbol)
  `(inst mov ,reg (make-ea-for-symbol-value ,symbol)))

(defmacro store-symbol-value (reg symbol)
  `(inst mov (make-ea-for-symbol-value ,symbol) ,reg))

#!+sb-thread
(defmacro make-ea-for-symbol-tls-index (symbol)
  `(make-ea :qword
    :disp (+ nil-value
           (static-symbol-offset ',symbol)
           (ash symbol-tls-index-slot word-shift)
           (- other-pointer-lowtag))))

#!+sb-thread
(defmacro load-tl-symbol-value (reg symbol)
  `(progn
    (inst mov ,reg (make-ea-for-symbol-tls-index ,symbol))
    (inst mov ,reg (make-ea :qword :base thread-base-tn :scale 1 :index ,reg))))
#!-sb-thread
(defmacro load-tl-symbol-value (reg symbol) `(load-symbol-value ,reg ,symbol))

#!+sb-thread
(defmacro store-tl-symbol-value (reg symbol temp)
  `(progn
    (inst mov ,temp (make-ea-for-symbol-tls-index ,symbol))
    (inst mov (make-ea :qword :base thread-base-tn :scale 1 :index ,temp) ,reg)))
#!-sb-thread
(defmacro store-tl-symbol-value (reg symbol temp)
  (declare (ignore temp))
  `(store-symbol-value ,reg ,symbol))

(defmacro load-binding-stack-pointer (reg)
  #!+sb-thread
  `(inst mov ,reg (make-ea :qword :base thread-base-tn
                   :disp (* 8 thread-binding-stack-pointer-slot)))
  #!-sb-thread
  `(load-symbol-value ,reg *binding-stack-pointer*))

(defmacro store-binding-stack-pointer (reg)
  #!+sb-thread
  `(inst mov (make-ea :qword :base thread-base-tn
              :disp (* 8 thread-binding-stack-pointer-slot))
    ,reg)
  #!-sb-thread
  `(store-symbol-value ,reg *binding-stack-pointer*))

(defmacro load-type (target source &optional (offset 0))
  #!+sb-doc
  "Loads the type bits of a pointer into target independent of
   byte-ordering issues."
  (once-only ((n-target target)
              (n-source source)
              (n-offset offset))
    (ecase *backend-byte-order*
      (:little-endian
       `(inst mov ,n-target
              (make-ea :byte :base ,n-source :disp ,n-offset)))
      (:big-endian
       `(inst mov ,n-target
              (make-ea :byte :base ,n-source
                             :disp (+ ,n-offset (1- n-word-bytes))))))))

;;;; allocation helpers

;;; All allocation is done by calls to assembler routines that
;;; eventually invoke the C alloc() function.

;;; Emit code to allocate an object with a size in bytes given by
;;; Size. The size may be an integer of a TN. If Inline is a VOP
;;; node-var then it is used to make an appropriate speed vs size
;;; decision.

(defun allocation-dynamic-extent (alloc-tn size lowtag)
  (inst sub rsp-tn size)
  ;; see comment in x86/macros.lisp implementation of this
  (inst and rsp-tn #.(lognot lowtag-mask))
  (aver (not (location= alloc-tn rsp-tn)))
  (inst lea alloc-tn (make-ea :byte :base rsp-tn :disp lowtag))
  (values))

;;; This macro should only be used inside a pseudo-atomic section,
;;; which should also cover subsequent initialization of the
;;; object.
(defun allocation-tramp (alloc-tn size lowtag)
  (inst push size)
  (inst lea temp-reg-tn (make-ea :qword
                            :disp (make-fixup "alloc_tramp" :foreign)))
  (inst call temp-reg-tn)
  (inst pop alloc-tn)
  (when lowtag
    (inst lea alloc-tn (make-ea :byte :base alloc-tn :disp lowtag)))
  (values))

(defun allocation (alloc-tn size &optional ignored dynamic-extent lowtag)
  (declare (ignore ignored))
  (when dynamic-extent
    (allocation-dynamic-extent alloc-tn size lowtag)
    (return-from allocation (values)))
  (let ((NOT-INLINE (gen-label))
        (DONE (gen-label))
        ;; Yuck.
        (in-elsewhere (eq *elsewhere* sb!assem::**current-segment**))
        ;; thread->alloc_region.free_pointer
        (free-pointer
         #!+sb-thread
         (make-ea :qword
                  :base thread-base-tn :scale 1
                  :disp (* n-word-bytes thread-alloc-region-slot))
         #!-sb-thread
         (make-ea :qword
                  :scale 1 :disp
                  (make-fixup "boxed_region" :foreign)))
        ;; thread->alloc_region.end_addr
        (end-addr
         #!+sb-thread
         (make-ea :qword
                  :base thread-base-tn :scale 1
                  :disp (* n-word-bytes (1+ thread-alloc-region-slot)))
         #!-sb-thread
         (make-ea :qword
                  :scale 1 :disp
                  (make-fixup "boxed_region" :foreign 8))))
    (cond (in-elsewhere
           (allocation-tramp alloc-tn size lowtag))
          (t
           (inst mov temp-reg-tn free-pointer)
           (if (tn-p size)
               (if (location= alloc-tn size)
                   (inst add alloc-tn temp-reg-tn)
                   (inst lea alloc-tn
                         (make-ea :qword :base temp-reg-tn :index size)))
               (inst lea alloc-tn
                     (make-ea :qword :base temp-reg-tn :disp size)))
           (inst cmp end-addr alloc-tn)
           (inst jmp :be NOT-INLINE)
           (inst mov free-pointer alloc-tn)
           (if lowtag
               (inst lea alloc-tn (make-ea :byte :base temp-reg-tn :disp lowtag))
               (inst mov alloc-tn temp-reg-tn))
           (emit-label DONE)
           (assemble (*elsewhere*)
             (emit-label NOT-INLINE)
             (cond ((numberp size)
                    (allocation-tramp alloc-tn size lowtag))
                   (t
                    (inst sub alloc-tn free-pointer)
                    (allocation-tramp alloc-tn alloc-tn lowtag)))
             (inst jmp DONE))))
    (values)))

;;; Allocate an other-pointer object of fixed SIZE with a single word
;;; header having the specified WIDETAG value. The result is placed in
;;; RESULT-TN.
(defmacro with-fixed-allocation ((result-tn widetag size &optional inline stack-allocate-p)
                                 &body forms)
  (unless forms
    (bug "empty &body in WITH-FIXED-ALLOCATION"))
  (once-only ((result-tn result-tn) (size size) (stack-allocate-p stack-allocate-p))
    `(maybe-pseudo-atomic ,stack-allocate-p
      (allocation ,result-tn (pad-data-block ,size) ,inline ,stack-allocate-p
                  other-pointer-lowtag)
      (storew (logior (ash (1- ,size) n-widetag-bits) ,widetag)
              ,result-tn 0 other-pointer-lowtag)
      ,@forms)))

;;;; error code
(defun emit-error-break (vop kind code values)
  (assemble ()
    #!-darwin
    (inst int 3)                  ; i386 breakpoint instruction
    ;; On Darwin, we need to use #x0b0f instead of int3 in order
    ;; to generate a SIGILL instead of a SIGTRAP as darwin/x86
    ;; doesn't seem to be reliably firing SIGTRAP
    ;; handlers. Hopefully this will be fixed by Apple at a
    ;; later date. Do the same on x86-64 as we do on x86 until this gets
    ;; sorted out.
    #!+darwin
    (inst word #x0b0f)
    ;; The return PC points here; note the location for the debugger.
    (when vop
      (note-this-location vop :internal-error))
    (inst byte kind)                       ; eg trap_Xyyy
    (with-adjustable-vector (vector)       ; interr arguments
      (write-var-integer code vector)
      (dolist (tn values)
        ;; classic CMU CL comment:
        ;;   zzzzz jrd here. tn-offset is zero for constant
        ;;   tns.
        (write-var-integer (make-sc-offset (sc-number (tn-sc tn))
                                           (or (tn-offset tn) 0))
                           vector))
      (inst byte (length vector))
      (dotimes (i (length vector))
        (inst byte (aref vector i))))))

(defun error-call (vop error-code &rest values)
  #!+sb-doc
  "Cause an error. ERROR-CODE is the error to cause."
  (emit-error-break vop error-trap (error-number-or-lose error-code) values))

(defun generate-error-code (vop error-code &rest values)
  #!+sb-doc
  "Generate-Error-Code Error-code Value*