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
)
106 (inst cmpxchg
(make-ea-for-symbol-value *tls-index-lock
*) target
)
107 (inst jmp
:ne get-tls-index-lock
)
108 ;; The symbol is now in OTHER.
110 ;; Now with the lock held, see if the symbol's tls index has been
111 ;; set in the meantime.
112 (loadw target other symbol-tls-index-slot other-pointer-lowtag
)
113 (inst or target target
)
114 (inst jmp
:ne release-tls-index-lock
)
115 ;; Allocate a new tls-index.
116 (load-symbol-value target
*free-tls-index
*)
117 (let ((error (generate-error-code nil
'tls-exhausted-error
)))
118 (inst cmp target
(fixnumize tls-size
))
119 (inst jmp
:ge error
))
120 (inst add
(make-ea-for-symbol-value *free-tls-index
*)
122 (storew target other symbol-tls-index-slot other-pointer-lowtag
)
123 (emit-label release-tls-index-lock
)
124 (store-symbol-value 0 *tls-index-lock
*)