alloc.lisp

开源跨平台Lisp编译器

;;;; allocating simple objects

;;;; 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")

;;;; Signed and unsigned bignums from word-sized integers. Argument
;;;; and return in the same register. No VOPs, as these are only used
;;;; as out-of-line versions: MOVE-FROM-[UN]SIGNED VOPs handle the
;;;; fixnum cases inline.

;;; #+SB-ASSEMBLING as we don't need VOPS, just the asm routines:
;;; these are out-of-line versions called by VOPs.

#+sb-assembling
(macrolet ((def (reg)
             (let ((tn (symbolicate reg "-TN")))
               `(define-assembly-routine (,(symbolicate "ALLOC-SIGNED-BIGNUM-IN-" reg)) ()
                  (inst push ,tn)
                  (with-fixed-allocation (,tn bignum-widetag (+ bignum-digits-offset 1))
                    (popw ,tn bignum-digits-offset other-pointer-lowtag))
                  (inst ret)))))
  (def eax)
  (def ebx)
  (def ecx)
  (def edx)
  (def edi)
  (def esi))

#+sb-assembling
(macrolet ((def (reg)
             (let ((tn (symbolicate reg "-TN")))
               `(define-assembly-routine (,(symbolicate "ALLOC-UNSIGNED-BIGNUM-IN-" reg)) ()
                  (inst push ,tn)
                  ;; Sign flag is set by the caller! Note: The inline
                  ;; version always allocates space for two words, but
                  ;; here we minimize garbage.
                  (inst jmp :ns one-word-bignum)
                  ;; Two word bignum
                  (with-fixed-allocation (,tn bignum-widetag (+ bignum-digits-offset 2))
                    (popw ,tn bignum-digits-offset other-pointer-lowtag))
                  (inst ret)
                  ONE-WORD-BIGNUM
                  (with-fixed-allocation (,tn bignum-widetag (+ bignum-digits-offset 1))
                    (popw ,tn bignum-digits-offset other-pointer-lowtag))
                  (inst ret)))))
  (def eax)
  (def ebx)
  (def ecx)
  (def edx)
  (def edi)
  (def esi))

;;; FIXME: This is dead, right? Can it go?
#+sb-assembling
(defun frob-allocation-assembly-routine (obj lowtag arg-tn)
  `(define-assembly-routine (,(intern (format nil "ALLOCATE-~A-TO-~A" obj arg-tn)))
     ((:temp ,arg-tn descriptor-reg ,(intern (format nil "~A-OFFSET" arg-tn))))
     (pseudo-atomic
      (allocation ,arg-tn (pad-data-block ,(intern (format nil "~A-SIZE" obj))))
      (inst lea ,arg-tn (make-ea :byte :base ,arg-tn :disp ,lowtag)))
     (inst ret)))

#+sb-assembling
(macrolet ((frob-cons-routines ()
             (let ((routines nil))
               (dolist (tn-offset *dword-regs*
                        `(progn ,@routines))
                 (push (frob-allocation-assembly-routine 'cons
                                                         list-pointer-lowtag
                                                         (intern (aref *dword-register-names* tn-offset)))
                       routines)))))
  (frob-cons-routines))

#+sb-assembling
(macrolet
    ((def (reg)
       (declare (ignorable reg))
       #!+sb-thread
       (let* ((name (intern (format nil "ALLOC-TLS-INDEX-IN-~A" reg)))
              (target-offset (intern (format nil "~A-OFFSET" reg)))
              (other-offset (if (eql 'eax reg)
                                'ecx-offset
                                'eax-offset)))
         ;; Symbol starts in TARGET, where the TLS-INDEX ends up in.
         `(define-assembly-routine ,name
              ((:temp other descriptor-reg ,other-offset)
               (:temp target descriptor-reg ,target-offset))
            (let ((get-tls-index-lock (gen-label))
                  (release-tls-index-lock (gen-label)))
              (pseudo-atomic
               ;; Save OTHER & push the symbol. EAX is either one of the two.
               (inst push other)
               (inst push target)
               (emit-label get-tls-index-lock)
               (inst mov target 1)
               (inst xor eax-tn eax-tn)
               (inst cmpxchg (make-ea-for-symbol-value *tls-index-lock*) target :lock)
               (inst jmp :ne get-tls-index-lock)
               ;; The symbol is now in OTHER.
               (inst pop other)
               ;; Now with the lock held, see if the symbol's tls index has been
               ;; set in the meantime.
               (loadw target other symbol-tls-index-slot other-pointer-lowtag)
               (inst or target target)
               (inst jmp :ne release-tls-index-lock)
               ;; Allocate a new tls-index.
               (load-symbol-value target *free-tls-index*)
               (let ((error (generate-error-code nil 'tls-exhausted-error)))
                 (inst cmp target (fixnumize tls-size))
                 (inst jmp :ge error))
               (inst add (make-ea-for-symbol-value *free-tls-index*)
                     (fixnumize 1))
               (storew target other symbol-tls-index-slot other-pointer-lowtag)
               (emit-label release-tls-index-lock)
               (store-symbol-value 0 *tls-index-lock*)
               ;; Restore OTHER.
               (inst pop other))
              (inst ret))))))
  (def eax)
  (def ebx)
  (def ecx)
  (def edx)
  (def edi)
  (def esi))