1 ;;;; allocating simple objects
3 ;;;; This software is part of the SBCL system. See the README file for
6 ;;;; This software is derived from the CMU CL system, which was
7 ;;;; written at Carnegie Mellon University and released into the
8 ;;;; public domain. The software is in the public domain and is
9 ;;;; provided with absolutely no warranty. See the COPYING and CREDITS
10 ;;;; files for more information.
14 ;;;; Signed and unsigned bignums from word-sized integers. Argument
15 ;;;; and return in the same register. No VOPs, as these are only used
16 ;;;; as out-of-line versions: MOVE-FROM-[UN]SIGNED VOPs handle the
17 ;;;; fixnum cases inline.
19 ;;; #+SB-ASSEMBLING as we don't need VOPS, just the asm routines:
20 ;;; these are out-of-line versions called by VOPs.
24 (let ((tn (symbolicate reg "-TN")))
25 `(define-assembly-routine (,(symbolicate "ALLOC-SIGNED-BIGNUM-IN-" reg)) ()
27 (with-fixed-allocation (,tn bignum-widetag (+ bignum-digits-offset 1))
28 (popw ,tn bignum-digits-offset other-pointer-lowtag))
39 (let ((tn (symbolicate reg "-TN")))
40 `(define-assembly-routine (,(symbolicate "ALLOC-UNSIGNED-BIGNUM-IN-" reg)) ()
42 ;; Sign flag is set by the caller! Note: The inline
43 ;; version always allocates space for two words, but
44 ;; here we minimize garbage.
45 (inst jmp :ns one-word-bignum)
47 (with-fixed-allocation (,tn bignum-widetag (+ bignum-digits-offset 2))
48 (popw ,tn bignum-digits-offset other-pointer-lowtag))
51 (with-fixed-allocation (,tn bignum-widetag (+ bignum-digits-offset 1))
52 (popw ,tn bignum-digits-offset other-pointer-lowtag))
61 ;;; FIXME: This is dead, right? Can it go?
63 (defun frob-allocation-assembly-routine (obj lowtag arg-tn)
64 `(define-assembly-routine (,(intern (format nil "ALLOCATE-~A-TO-~A" obj arg-tn)))
65 ((:temp ,arg-tn descriptor-reg ,(intern (format nil "~A-OFFSET" arg-tn))))
67 (allocation ,arg-tn (pad-data-block ,(intern (format nil "~A-SIZE" obj))))
68 (inst lea ,arg-tn (make-ea :byte :base ,arg-tn :disp ,lowtag)))
72 (macrolet ((frob-cons-routines ()
74 (dolist (tn-offset *dword-regs*
76 (push (frob-allocation-assembly-routine 'cons
78 (intern (aref *dword-register-names* tn-offset)))
85 (declare (ignorable reg))
87 (let* ((name (intern (format nil "ALLOC-TLS-INDEX-IN-~A" reg)))
88 (target-offset (intern (format nil "~A-OFFSET" reg)))
89 (other-offset (if (eql 'eax reg)
92 ;; Symbol starts in TARGET, where the TLS-INDEX ends up in.
93 `(define-assembly-routine ,name
94 ((:temp other descriptor-reg ,other-offset)
95 (:temp target descriptor-reg ,target-offset))
96 (let ((get-tls-index-lock (gen-label))
97 (release-tls-index-lock (gen-label)))
99 ;; Save OTHER & push the symbol. EAX is either one of the two.
102 (emit-label get-tls-index-lock)
104 (inst xor eax-tn eax-tn)
105 (inst cmpxchg (make-ea-for-symbol-value *tls-index-lock*) target :lock)
106 (inst jmp :ne get-tls-index-lock)
107 ;; The symbol is now in OTHER.
109 ;; Now with the lock held, see if the symbol's tls index has been
110 ;; set in the meantime.
111 (loadw target other symbol-tls-index-slot other-pointer-lowtag)
112 (inst or target target)
113 (inst jmp :ne release-tls-index-lock)
114 ;; Allocate a new tls-index.
115 (load-symbol-value target *free-tls-index*)
116 (let ((error (generate-error-code nil 'tls-exhausted-error)))
117 (inst cmp target (fixnumize tls-size))
118 (inst jmp :ge error))
119 (inst add (make-ea-for-symbol-value *free-tls-index*)
121 (storew target other symbol-tls-index-slot other-pointer-lowtag)
122 (emit-label release-tls-index-lock)
123 (store-symbol-value 0 *tls-index-lock*)