1;;;; allocating simple objects
2
3;;;; This software is part of the SBCL system. See the README file for
4;;;; more information.
5;;;;
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.
11
12(in-package "SB!VM")
13
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.
18
19;;; #+SB-ASSEMBLING as we don't need VOPS, just the asm routines:
20;;; these are out-of-line versions called by VOPs.
21
22#+sb-assembling
23(macrolet ((def (reg)
24             (let ((tn (symbolicate reg "-TN")))
25               `(define-assembly-routine (,(symbolicate "ALLOC-SIGNED-BIGNUM-IN-" reg)) ()
26                  (inst push ,tn)
27                  (with-fixed-allocation (,tn bignum-widetag (+ bignum-digits-offset 1))
28                    (popw ,tn bignum-digits-offset other-pointer-lowtag))))))
29  (def eax)
30  (def ebx)
31  (def ecx)
32  (def edx)
33  (def edi)
34  (def esi))
35
36#+sb-assembling
37(macrolet ((def (reg)
38             (let ((tn (symbolicate reg "-TN")))
39               `(define-assembly-routine (,(symbolicate "ALLOC-UNSIGNED-BIGNUM-IN-" reg)) ()
40                  (inst push ,tn)
41                  ;; Sign flag is set by the caller! Note: The inline
42                  ;; version always allocates space for two words, but
43                  ;; here we minimize garbage.
44                  (inst jmp :ns one-word-bignum)
45                  ;; Two word bignum
46                  (with-fixed-allocation (,tn bignum-widetag (+ bignum-digits-offset 2))
47                    (popw ,tn bignum-digits-offset other-pointer-lowtag))
48                  (inst ret)
49                  ONE-WORD-BIGNUM
50                  (with-fixed-allocation (,tn bignum-widetag (+ bignum-digits-offset 1))
51                    (popw ,tn bignum-digits-offset other-pointer-lowtag))))))
52  (def eax)
53  (def ebx)
54  (def ecx)
55  (def edx)
56  (def edi)
57  (def esi))
58
59;;; FIXME: This is dead, right? Can it go?
60#+sb-assembling
61(defun frob-allocation-assembly-routine (obj lowtag arg-tn)
62  `(define-assembly-routine (,(intern (format nil "ALLOCATE-~A-TO-~A" obj arg-tn)))
63     ((:temp ,arg-tn descriptor-reg ,(intern (format nil "~A-OFFSET" arg-tn))))
64     (pseudo-atomic
65      (allocation ,arg-tn (pad-data-block ,(intern (format nil "~A-SIZE" obj))))
66      (inst lea ,arg-tn (make-ea :byte :base ,arg-tn :disp ,lowtag)))))
67
68#+sb-assembling
69(macrolet ((frob-cons-routines ()
70             (let ((routines nil))
71               (dolist (tn-offset *dword-regs*
72                        `(progn ,@routines))
73                 (push (frob-allocation-assembly-routine 'cons
74                                                         list-pointer-lowtag
75                                                         (intern (aref *dword-register-names* tn-offset)))
76                       routines)))))
77  (frob-cons-routines))
78
79#!+sb-thread
80(define-assembly-routine (alloc-tls-index
81                          (:translate ensure-symbol-tls-index)
82                          (:result-types positive-fixnum)
83                          (:policy :fast-safe))
84    ;; The vop result is unsigned-reg because the assembly routine does not
85    ;; fixnumize its answer, which is confusing because it looks like a fixnum.
86    ;; But the result of the function ENSURE-SYMBOL-TLS-INDEX is a fixnum whose
87    ;; value in Lisp is the number that the assembly code computes,
88    ;; *not* the fixnum whose representation it computes.
89    ((:arg symbol (descriptor-reg) eax-offset) ; both input and output
90     (:res result (unsigned-reg) eax-offset))
91  (let ((scratch-reg ecx-tn) ; ECX gets callee-saved, not declared as a temp
92        (free-tls-index-ea (make-ea-for-symbol-value *free-tls-index*))
93        (lock-bit 31) ; sign bit
94        (tls-full (gen-label)))
95    ;; A pseudo-atomic section avoids bad behavior if the current thread were
96    ;; to receive an interrupt causing it to do a slow operation between
97    ;; acquisition and release of the spinlock. Preventing GC is irrelevant,
98    ;; but would not be if we recycled tls indices of garbage symbols.
99    (pseudo-atomic
100     (assemble () ; for conversion of tagbody-like labels to assembler labels
101     RETRY
102       (inst bts free-tls-index-ea lock-bit :lock)
103       (inst jmp :nc got-tls-index-lock)
104       (inst pause) ; spin loop hint
105       ;; TODO: yielding the CPU here might be a good idea
106       (inst jmp retry)
107     GOT-TLS-INDEX-LOCK
108       ;; Now we hold the spinlock. With it held, see if the symbol's
109       ;; tls-index has been set in the meantime.
110       (inst cmp (tls-index-of symbol) 0)
111       (inst jmp :e new-tls-index)
112       ;; TLS index is valid, so use it.
113       (inst and (make-ea :byte :disp (+ (ea-disp free-tls-index-ea) 3)) #x7F
114             :lock) ; set the spinlock bit to 0
115       (inst jmp done)
116     NEW-TLS-INDEX
117       ;; Allocate a new tls-index.
118       (inst push scratch-reg)
119       (inst mov scratch-reg free-tls-index-ea)
120       (inst and scratch-reg #x7FFFFFFF) ; mask off the sign
121       (inst cmp scratch-reg (* tls-size n-word-bytes))
122       (inst jmp :ae tls-full)
123       ;; Assign the tls-index into the symbol
124       (inst mov (tls-index-of symbol) scratch-reg)
125       ;; Bump the free index and clear the lock.
126       (inst add scratch-reg n-word-bytes)
127       (inst mov free-tls-index-ea scratch-reg)
128       (inst pop scratch-reg)
129     DONE
130       (inst mov result (tls-index-of symbol)))) ; end PSEUDO-ATOMIC
131    (inst ret)
132    (emit-label tls-full)
133    (inst mov free-tls-index-ea scratch-reg) ; unlock
134    (inst pop scratch-reg) ; balance the stack
135    (%clear-pseudo-atomic)
136    ;; There's a spurious RET instruction auto-inserted, but no matter.
137    (error-call nil 'tls-exhausted-error)))
138