Don't go through fdefn when referencing #'known-functions.
[sbcl.git] / src / assembly / x86 / alloc.lisp
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 \f
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                   (inst ret)))))
30   (def eax)
31   (def ebx)
32   (def ecx)
33   (def edx)
34   (def edi)
35   (def esi))
36
37 #+sb-assembling
38 (macrolet ((def (reg)
39              (let ((tn (symbolicate reg "-TN")))
40                `(define-assembly-routine (,(symbolicate "ALLOC-UNSIGNED-BIGNUM-IN-" reg)) ()
41                   (inst push ,tn)
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)
46                   ;; Two word bignum
47                   (with-fixed-allocation (,tn bignum-widetag (+ bignum-digits-offset 2))
48                     (popw ,tn bignum-digits-offset other-pointer-lowtag))
49                   (inst ret)
50                   ONE-WORD-BIGNUM
51                   (with-fixed-allocation (,tn bignum-widetag (+ bignum-digits-offset 1))
52                     (popw ,tn bignum-digits-offset other-pointer-lowtag))
53                   (inst ret)))))
54   (def eax)
55   (def ebx)
56   (def ecx)
57   (def edx)
58   (def edi)
59   (def esi))
60
61 ;;; FIXME: This is dead, right? Can it go?
62 #+sb-assembling
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))))
66      (pseudo-atomic
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)))
69      (inst ret)))
70
71 #+sb-assembling
72 (macrolet ((frob-cons-routines ()
73              (let ((routines nil))
74                (dolist (tn-offset *dword-regs*
75                         `(progn ,@routines))
76                  (push (frob-allocation-assembly-routine 'cons
77                                                          list-pointer-lowtag
78                                                          (intern (aref *dword-register-names* tn-offset)))
79                        routines)))))
80   (frob-cons-routines))
81
82 #+sb-assembling
83 (macrolet
84     ((def (reg)
85        (declare (ignorable reg))
86        #!+sb-thread
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)
90                                 'ecx-offset
91                                 'eax-offset)))
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)))
98               (pseudo-atomic
99                ;; Save OTHER & push the symbol. EAX is either one of the two.
100                (inst push other)
101                (inst push target)
102                (emit-label get-tls-index-lock)
103                (let ((not-eax ,(if (eql 'eax reg) 'other 'target)))
104                  (inst mov not-eax 1)
105                  (inst xor eax-tn eax-tn)
106                  (inst cmpxchg (make-ea-for-symbol-value *tls-index-lock*)
107                        not-eax :lock)
108                  (inst jmp :ne get-tls-index-lock))
109                ;; The symbol is now in OTHER.
110                (inst pop other)
111                ;; Now with the lock held, see if the symbol's tls index has been
112                ;; set in the meantime.
113                (loadw target other symbol-tls-index-slot other-pointer-lowtag)
114                (inst test target target)
115                (inst jmp :ne release-tls-index-lock)
116                ;; Allocate a new tls-index.
117                (load-symbol-value target *free-tls-index*)
118                (let ((not-error (gen-label))
119                      (error (generate-error-code nil 'tls-exhausted-error)))
120                  (inst cmp target (ash tls-size word-shift))
121                  (inst jmp :l not-error)
122                  (%clear-pseudo-atomic)
123                  (inst jmp error)
124                  (emit-label not-error))
125                (inst add (make-ea-for-symbol-value *free-tls-index*)
126                      n-word-bytes)
127                (storew target other symbol-tls-index-slot other-pointer-lowtag)
128                (emit-label release-tls-index-lock)
129                ;; No need for barriers on x86/x86-64 on unlock.
130                (store-symbol-value 0 *tls-index-lock*)
131                ;; Restore OTHER.
132                (inst pop other))
133               (inst ret))))))
134   (def eax)
135   (def ebx)
136   (def ecx)
137   (def edx)
138   (def edi)
139   (def esi))