macros.lisp

开源跨平台Lisp编译器

;;;; various useful macros for generating Alpha code

;;;; 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")

;;; a handy macro for defining top level forms that depend on the
;;; compile environment
(defmacro expand (expr)
  (let ((gensym (gensym)))
    `(macrolet
         ((,gensym ()
            ,expr))
       (,gensym))))

;;; instruction-like macros

;;; c.f. x86 backend:
;;(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)
;;       (inst mov ,n-dst ,n-src))))

(defmacro move (src dst)
  "Move SRC into DST unless they are location=."
  (once-only ((n-src src) (n-dst dst))
    `(unless (location= ,n-src ,n-dst)
       (inst move ,n-src ,n-dst))))

(defmacro loadw (result base &optional (offset 0) (lowtag 0))
  (once-only ((result result) (base base))
    `(inst ldl ,result (- (ash ,offset word-shift) ,lowtag) ,base)))

(defmacro loadq (result base &optional (offset 0) (lowtag 0))
  (once-only ((result result) (base base))
    `(inst ldq ,result (- (ash ,offset word-shift) ,lowtag) ,base)))

(defmacro storew (value base &optional (offset 0) (lowtag 0))
  (once-only ((value value) (base base) (offset offset) (lowtag lowtag))
    `(inst stl ,value (- (ash ,offset word-shift) ,lowtag) ,base)))

(defmacro storeq (value base &optional (offset 0) (lowtag 0))
  (once-only ((value value) (base base) (offset offset) (lowtag lowtag))
    `(inst stq ,value (- (ash ,offset word-shift) ,lowtag) ,base)))

(defmacro load-symbol (reg symbol)
  (once-only ((reg reg) (symbol symbol))
    `(inst lda ,reg (static-symbol-offset ,symbol) null-tn)))

(defmacro load-symbol-value (reg symbol)
  `(inst ldl ,reg
         (+ (static-symbol-offset ',symbol)
            (ash symbol-value-slot word-shift)
            (- other-pointer-lowtag))
         null-tn))

(defmacro store-symbol-value (reg symbol)
  `(inst stl ,reg
         (+ (static-symbol-offset ',symbol)
            (ash symbol-value-slot word-shift)
            (- other-pointer-lowtag))
         null-tn))

(defmacro load-type (target source &optional (offset 0))
  "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))
     `(progn
        (inst ldl ,n-target ,n-offset ,n-source)
        (inst and ,n-target #xff ,n-target))))

;;; macros to handle the fact that we cannot use the machine native
;;; call and return instructions

(defmacro lisp-jump (function lip)
  "Jump to the lisp function FUNCTION.  LIP is an interior-reg temporary."
  `(progn
     (inst lda ,lip (- (ash simple-fun-code-offset word-shift)
                       fun-pointer-lowtag)
            ,function)
     (move ,function code-tn)
     (inst jsr zero-tn ,lip 1)))

(defmacro lisp-return (return-pc lip &key (offset 0) (frob-code t))
  "Return to RETURN-PC.  LIP is an interior-reg temporary."
  `(progn
     (inst lda ,lip
           (- (* (1+ ,offset) n-word-bytes) other-pointer-lowtag)
            ,return-pc)
     ,@(when frob-code
         `((move ,return-pc code-tn)))
     (inst ret zero-tn ,lip 1)))


(defmacro emit-return-pc (label)
  "Emit a return-pc header word.  LABEL is the label to use for this
   return-pc."
  `(progn
     (emit-alignment n-lowtag-bits)
     (emit-label ,label)
     (inst lra-header-word)))



;;;; stack TN's

;;;    Move a stack TN to a register and vice-versa.
(defmacro load-stack-tn (reg stack)
  `(let ((reg ,reg)
         (stack ,stack))
     (let ((offset (tn-offset stack)))
       (sc-case stack
         ((control-stack)
          (loadw reg cfp-tn offset))))))
(defmacro store-stack-tn (stack reg)
  `(let ((stack ,stack)
         (reg ,reg))
     (let ((offset (tn-offset stack)))
       (sc-case stack
         ((control-stack)
          (storew reg cfp-tn offset))))))

;;; Move the TN Reg-Or-Stack into Reg if it isn't already there.
(defmacro maybe-load-stack-tn (reg reg-or-stack)
  (once-only ((n-reg reg)
              (n-stack reg-or-stack))
    `(sc-case ,n-reg
       ((any-reg descriptor-reg)
        (sc-case ,n-stack
          ((any-reg descriptor-reg)
           (move ,n-stack ,n-reg))
          ((control-stack)
           (loadw ,n-reg cfp-tn (tn-offset ,n-stack))))))))

;;; Move the TN Reg-Or-Stack into Reg if it isn't already there.
(defmacro maybe-load-stack-nfp-tn (reg reg-or-stack temp)
  (once-only ((n-reg reg)
              (n-stack reg-or-stack))
     `(when ,reg
        (sc-case ,n-reg
         ((any-reg descriptor-reg)
          (sc-case ,n-stack
           ((any-reg descriptor-reg)
            (move ,n-stack ,n-reg))
           ((control-stack)
            (loadw ,n-reg cfp-tn (tn-offset ,n-stack))
            (inst mskll nsp-tn 0 ,temp)
            (inst bis ,temp ,n-reg ,n-reg))))))))

;;;; storage allocation

;;; Do stuff to 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, Flag-Tn must be wired to NL3-OFFSET, and
;;; Temp-TN is a non- descriptor temp (which may be randomly used by
;;; the body.) The body is placed inside the PSEUDO-ATOMIC, and
;;; presumably initializes the object.
(defmacro with-fixed-allocation ((result-tn temp-tn widetag size)
                                 &body body)
  (unless body
    (bug "empty &body in WITH-FIXED-ALLOCATION"))
  (once-only ((result-tn result-tn) (temp-tn temp-tn) (size size))
    `(pseudo-atomic (:extra (pad-data-block ,size))
       (inst bis alloc-tn other-pointer-lowtag ,result-tn)
       (inst li (logior (ash (1- ,size) n-widetag-bits) ,widetag) ,temp-tn)
       (storew ,temp-tn ,result-tn 0 other-pointer-lowtag)
       ,@body)))

(defun align-csp (temp)
  ;; is used for stack allocation of dynamic-extent objects
  (let ((aligned (gen-label)))
    (inst and csp-tn lowtag-mask temp)
    (inst beq temp aligned)
    (inst addq csp-tn n-word-bytes csp-tn)
    (storew zero-tn csp-tn -1)
    (emit-label aligned)))

;;;; error code
(eval-when (:compile-toplevel :load-toplevel :execute)
  (defun emit-error-break (vop kind code values)
    (let ((vector (gensym)))
      `((let ((vop ,vop))
          (when vop
            (note-this-location vop :internal-error)))
        (inst gentrap ,kind)
        (with-adjustable-vector (,vector)
          (write-var-integer (error-number-or-lose ',code) ,vector)
          ,@(mapcar (lambda (tn)
                      `(let ((tn ,tn))
                         (write-var-integer (make-sc-offset (sc-number
                                                             (tn-sc tn))
                                                            (tn-offset tn))
                                            ,vector)))
                    values)
          (inst byte (length ,vector))
          (dotimes (i (length ,vector))
            (inst byte (aref ,vector i))))
        (emit-alignment word-shift)))))

(defmacro error-call (vop error-code &rest values)
  "Cause an error.  ERROR-CODE is the error to cause."
  (cons 'progn
        (emit-error-break vop error-trap error-code values)))


(defmacro cerror-call (vop label error-code &rest values)
  "Cause a continuable error.  If the error is continued, execution resumes at
  LABEL."
  `(progn
     (inst br zero-tn ,label)
     ,@(emit-error-break vop cerror-trap error-code values)))

(defmacro generate-error-code (vop error-code &rest values)
  "Generate-Error-Code Error-code Value*
  Emit code for an error with the specified Error-Code and context Values."
  `(assemble (*elsewhere*)
     (let ((start-lab (gen-label)))
       (emit-label start-lab)
       (error-call ,vop ,error-code ,@values)
       start-lab)))

(defmacro generate-cerror-code (vop error-code &rest values)
  "Generate-CError-Code Error-code Value*
  Emit code for a continuable error with the specified Error-Code and
  context Values.  If the error is continued, execution resumes after
  the GENERATE-CERROR-CODE form."
  (with-unique-names (continue error)
    `(let ((,continue (gen-label)))
       (emit-label ,continue)
       (assemble (*elsewhere*)
         (let ((,error (gen-label)))
           (emit-label ,error)
           (cerror-call ,vop ,continue ,error-code ,@values)
           ,error)))))


;;; a handy macro for making sequences look atomic
(defmacro pseudo-atomic ((&key (extra 0)) &rest forms)
  `(progn
     (inst addq alloc-tn 1 alloc-tn)
     ,@forms
     (inst lda alloc-tn (1- ,extra) alloc-tn)
     (inst stl zero-tn 0 alloc-tn)))

;;;; memory accessor vop generators

(defmacro define-full-reffer (name type offset lowtag scs el-type
                                   &optional translate)
  `(progn
     (define-vop (,name)
       ,@(when translate
           `((:translate ,translate)))
       (:policy :fast-safe)