vm.lisp

开源跨平台Lisp编译器

              :element-size 2
;             :reserve-locations (#.eax-offset)
              :constant-scs (immediate)
              :save-p t
              :alternate-scs (signed-stack))
  (unsigned-reg registers
                :locations #.*dword-regs*
                :element-size 2
;               :reserve-locations (#.eax-offset)
                :constant-scs (immediate)
                :save-p t
                :alternate-scs (unsigned-stack))

  ;; miscellaneous objects that must not be seen by GC. Used only as
  ;; temporaries.
  (word-reg registers
            :locations #.*word-regs*
            :element-size 2
;           :reserve-locations (#.ax-offset)
            )
  (byte-reg registers
            :locations #.*byte-regs*
;           :reserve-locations (#.al-offset #.ah-offset)
            )

  ;; that can go in the floating point registers

  ;; non-descriptor SINGLE-FLOATs
  (single-reg float-registers
              :locations (0 1 2 3 4 5 6 7)
              :constant-scs (fp-constant)
              :save-p t
              :alternate-scs (single-stack))

  ;; non-descriptor DOUBLE-FLOATs
  (double-reg float-registers
              :locations (0 1 2 3 4 5 6 7)
              :constant-scs (fp-constant)
              :save-p t
              :alternate-scs (double-stack))

  ;; non-descriptor LONG-FLOATs
  #!+long-float
  (long-reg float-registers
            :locations (0 1 2 3 4 5 6 7)
            :constant-scs (fp-constant)
            :save-p t
            :alternate-scs (long-stack))

  (complex-single-reg float-registers
                      :locations (0 2 4 6)
                      :element-size 2
                      :constant-scs ()
                      :save-p t
                      :alternate-scs (complex-single-stack))

  (complex-double-reg float-registers
                      :locations (0 2 4 6)
                      :element-size 2
                      :constant-scs ()
                      :save-p t
                      :alternate-scs (complex-double-stack))

  #!+long-float
  (complex-long-reg float-registers
                    :locations (0 2 4 6)
                    :element-size 2
                    :constant-scs ()
                    :save-p t
                    :alternate-scs (complex-long-stack))

  ;; a catch or unwind block
  (catch-block stack :element-size kludge-nondeterministic-catch-block-size))

(eval-when (:compile-toplevel :load-toplevel :execute)
(defparameter *byte-sc-names*
  '(#!-sb-unicode character-reg byte-reg #!-sb-unicode character-stack))
(defparameter *word-sc-names* '(word-reg))
(defparameter *dword-sc-names*
  '(any-reg descriptor-reg sap-reg signed-reg unsigned-reg control-stack
    signed-stack unsigned-stack sap-stack single-stack
    #!+sb-unicode character-reg #!+sb-unicode character-stack constant))
;;; added by jrd. I guess the right thing to do is to treat floats
;;; as a separate size...
;;;
;;; These are used to (at least) determine operand size.
(defparameter *float-sc-names* '(single-reg))
(defparameter *double-sc-names* '(double-reg double-stack))
) ; EVAL-WHEN

;;;; miscellaneous TNs for the various registers

(macrolet ((def-misc-reg-tns (sc-name &rest reg-names)
             (collect ((forms))
                      (dolist (reg-name reg-names)
                        (let ((tn-name (symbolicate reg-name "-TN"))
                              (offset-name (symbolicate reg-name "-OFFSET")))
                          ;; FIXME: It'd be good to have the special
                          ;; variables here be named with the *FOO*
                          ;; convention.
                          (forms `(defparameter ,tn-name
                                    (make-random-tn :kind :normal
                                                    :sc (sc-or-lose ',sc-name)
                                                    :offset
                                                    ,offset-name)))))
                      `(progn ,@(forms)))))

  (def-misc-reg-tns unsigned-reg eax ebx ecx edx ebp esp edi esi)
  (def-misc-reg-tns word-reg ax bx cx dx bp sp di si)
  (def-misc-reg-tns byte-reg al ah bl bh cl ch dl dh)
  (def-misc-reg-tns single-reg fr0 fr1 fr2 fr3 fr4 fr5 fr6 fr7))

;;; TNs for registers used to pass arguments
(defparameter *register-arg-tns*
  (mapcar (lambda (register-arg-name)
            (symbol-value (symbolicate register-arg-name "-TN")))
          *register-arg-names*))

;;; FIXME: doesn't seem to be used in SBCL
#|
;;; added by pw
(defparameter fp-constant-tn
  (make-random-tn :kind :normal
                  :sc (sc-or-lose 'fp-constant)
                  :offset 31))          ; Offset doesn't get used.
|#

;;; If value can be represented as an immediate constant, then return
;;; the appropriate SC number, otherwise return NIL.
(!def-vm-support-routine immediate-constant-sc (value)
  (typecase value
    ((or (integer #.sb!xc:most-negative-fixnum #.sb!xc:most-positive-fixnum)
         character)
     (sc-number-or-lose 'immediate))
    (symbol
     (when (static-symbol-p value)
       (sc-number-or-lose 'immediate)))
    (single-float
     (when (or (eql value 0f0) (eql value 1f0))
       (sc-number-or-lose 'fp-constant)))
    (double-float
     (when (or (eql value 0d0) (eql value 1d0))
       (sc-number-or-lose 'fp-constant)))
    #!+long-float
    (long-float
     (when (or (eql value 0l0) (eql value 1l0)
               (eql value pi)
               (eql value (log 10l0 2l0))
               (eql value (log 2.718281828459045235360287471352662L0 2l0))
               (eql value (log 2l0 10l0))
               (eql value (log 2l0 2.718281828459045235360287471352662L0)))
       (sc-number-or-lose 'fp-constant)))))

;; For an immediate TN, return its value encoded for use as a literal.
;; For any other TN, return the TN.  Only works for FIXNUMs,
;; STATIC-SYMBOLs, and CHARACTERS (FLOATs and SAPs are handled
;; elsewhere).
(defun encode-value-if-immediate (tn)
  (if (sc-is tn immediate)
      (let ((val (tn-value tn)))
        (etypecase val
          (integer (fixnumize val))
          (symbol (+ nil-value (static-symbol-offset val)))
          (character (logior (ash (char-code val) n-widetag-bits)
                             character-widetag))))
      tn))

;;;; miscellaneous function call parameters

;;; offsets of special stack frame locations
(def!constant ocfp-save-offset 0)
(def!constant return-pc-save-offset 1)

(declaim (inline frame-word-offset))
(defun frame-word-offset (index)
  (- (1+ index)))

(declaim (inline frame-byte-offset))
(defun frame-byte-offset (index)
  (* (frame-word-offset index) n-word-bytes))

;;; FIXME: This is a bad comment (changed since when?) and there are others
;;; like it in this file. It'd be nice to clarify them. Failing that deleting
;;; them or flagging them with KLUDGE might be better than nothing.
;;;
;;; names of these things seem to have changed. these aliases by jrd
(def!constant lra-save-offset return-pc-save-offset)

(def!constant cfp-offset ebp-offset)    ; pfw - needed by stuff in /code
                                        ; related to signal context stuff

;;; This is used by the debugger.
(def!constant single-value-return-byte-offset 2)

;;; This function is called by debug output routines that want a pretty name
;;; for a TN's location. It returns a thing that can be printed with PRINC.
(!def-vm-support-routine location-print-name (tn)
  (declare (type tn tn))
  (let* ((sc (tn-sc tn))
         (sb (sb-name (sc-sb sc)))
         (offset (tn-offset tn)))
    (ecase sb
      (registers
       (let* ((sc-name (sc-name sc))
              (name-vec (cond ((member sc-name *byte-sc-names*)
                               *byte-register-names*)
                              ((member sc-name *word-sc-names*)
                               *word-register-names*)
                              ((member sc-name *dword-sc-names*)
                               *dword-register-names*))))
         (or (and name-vec
                  (< -1 offset (length name-vec))
                  (svref name-vec offset))
             ;; FIXME: Shouldn't this be an ERROR?
             (format nil "<unknown reg: off=~W, sc=~A>" offset sc-name))))
      (float-registers (format nil "FR~D" offset))
      (stack (format nil "S~D" offset))
      (constant (format nil "Const~D" offset))
      (immediate-constant "Immed")
      (noise (symbol-name (sc-name sc))))))
;;; FIXME: Could this, and everything that uses it, be made #!+SB-SHOW?

(!def-vm-support-routine combination-implementation-style (node)
  (declare (type sb!c::combination node))
  (flet ((valid-funtype (args result)
           (sb!c::valid-fun-use node
                                (sb!c::specifier-type
                                 `(function ,args ,result)))))
    (case (sb!c::combination-fun-source-name node)
      (logtest
       (cond
         ((valid-funtype '(fixnum fixnum) '*)
          (values :direct nil))
         ((valid-funtype '((signed-byte 32) (signed-byte 32)) '*)
          (values :direct nil))
         ((valid-funtype '((unsigned-byte 32) (unsigned-byte 32)) '*)
          (values :direct nil))
         (t (values :default nil))))
      (logbitp
       (cond
         ((and (valid-funtype '((integer 0 29) fixnum) '*)
               (sb!c::constant-lvar-p (first (sb!c::basic-combination-args node))))
          (values :transform '(lambda (index integer)
                               (%logbitp integer index))))
         ((valid-funtype '((integer 0 31) (signed-byte 32)) '*)
          (values :transform '(lambda (index integer)
                               (%logbitp integer index))))
         ((valid-funtype '((integer 0 31) (unsigned-byte 32)) '*)
          (values :transform '(lambda (index integer)
                               (%logbitp integer index))))
         (t (values :default nil))))
      (t (values :default nil)))))