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 ;;;; Notinline allocators
15 ;;;; Allocate bytes and return the start of the allocated space
16 ;;;; in the specified destination register.
18 ;;;; In the general case the size will be in the destination register.
20 ;;;; All registers must be preserved except the destination.
21 ;;;; The C conventions will preserve ebx, esi, edi, and ebp.
22 ;;;; So only eax, ecx, and edx need special care here.
24 ;;;; ALLOC factors out the logic of calling alloc(): stack alignment, etc.
26 (macrolet ((alloc (reg size c-fun
)
29 (inst mov ebp-tn esp-tn
)
30 (inst push
0) ; reserve space for arg
31 (inst and esp-tn
#xfffffff0
) ; align stack to 16 bytes
32 (inst mov
(make-ea :dword
:base esp-tn
) ,size
)
33 (inst call
(make-fixup ,c-fun
:foreign
))
34 (inst mov esp-tn ebp-tn
)
36 ,@(unless (eq reg
'eax-tn
)
37 `((inst mov
,reg eax-tn
)))))
38 (preserving ((r1 r2
&optional r3
) &body body
)
39 `(progn (inst push
,r1
) (inst push
,r2
)
40 ,@(when r3
`((inst push
,r3
)))
42 ,@(when r3
`((inst pop
,r3
)))
43 (inst pop
,r2
) (inst pop
,r1
)))
44 (alloc-to-reg (reg size
&optional
(c-fun "alloc"))
48 #+win32
; use edx-tn as a scratch reg unless REG is edx, then use ecx-tn
49 (let ((scratch-tn (if (eq reg
'edx-tn
) 'ecx-tn
'edx-tn
)))
50 `((inst mov
,scratch-tn
51 (make-ea :dword
:disp
+win32-tib-arbitrary-field-offset
+)
53 (inst sub
,reg
(make-ea :dword
:disp
(ash thread-mixed-tlab-slot
2)
56 `(#+sb-thread
(inst sub
,reg
57 (make-ea :dword
:disp
(ash thread-mixed-tlab-slot
2))
59 #-sb-thread
(inst sub
,reg
61 (+ static-space-start mixed-region-offset
)))))))
63 ;; Now that we're using lisp asm code instead of a .S file
64 ;; this could be done more intelligently - the macro can decide
65 ;; on a temp register.
66 (eax-tn `(preserving (ecx-tn edx-tn
)
67 ,@size-calc
(alloc eax-tn
,size
,c-fun
)))
68 (ecx-tn `(preserving (eax-tn edx-tn
)
69 ,@size-calc
(alloc ecx-tn
,size
,c-fun
)))
70 (edx-tn `(preserving (eax-tn ecx-tn
)
71 ,@size-calc
(alloc edx-tn
,size
,c-fun
)))
72 (t `(preserving (eax-tn ecx-tn edx-tn
)
73 ,@size-calc
(alloc ,reg
,size
,c-fun
))))))
74 (def-allocators (tn &aux
(reg (subseq (string tn
) 0 3)))
76 (define-assembly-routine (,(symbolicate "ALLOC-OVERFLOW-" reg
)) ()
77 (alloc-to-reg ,tn nil
))
78 (define-assembly-routine (,(symbolicate "ALLOC-LIST-OVERFLOW-" reg
)) ()
79 (alloc-to-reg ,tn nil
"alloc_list"))
80 ;; FIXME: having decided (based on policy) not to use the inline allocator
81 ;; in Lisp, why does the assembly code not try to inline it?
82 ;; There's no reason to call into C for everything. This is horrible.
83 (define-assembly-routine (,(symbolicate "ALLOC-TO-" reg
)) ()
84 (alloc-to-reg ,tn
,tn
))
85 (define-assembly-routine (,(symbolicate "ALLOC-LIST-TO-" reg
)) ()
86 (alloc-to-reg ,tn
,tn
"alloc_list"))
87 (define-assembly-routine (,(symbolicate "ALLOC-8-TO-" reg
)) ()
89 (define-assembly-routine (,(symbolicate "ALLOC-16-TO-" reg
)) ()
90 (alloc-to-reg ,tn
16)))))
91 (def-allocators eax-tn
)
92 (def-allocators ecx-tn
)
93 (def-allocators edx-tn
)
94 (def-allocators ebx-tn
)
95 (def-allocators esi-tn
)
96 (def-allocators edi-tn
))
98 ;;;; Signed and unsigned bignums from word-sized integers. Argument
99 ;;;; and return in the same register. No VOPs, as these are only used
100 ;;;; as out-of-line versions: MOVE-FROM-[UN]SIGNED VOPs handle the
101 ;;;; fixnum cases inline.
103 ;;; #+SB-ASSEMBLING as we don't need VOPS, just the asm routines:
104 ;;; these are out-of-line versions called by VOPs.
107 (macrolet ((def (reg)
108 (let ((tn (symbolicate reg
"-TN")))
109 `(define-assembly-routine (,(symbolicate "ALLOC-SIGNED-BIGNUM-IN-" reg
)) ()
111 (alloc-other ,tn bignum-widetag
(+ bignum-digits-offset
1) nil
)
112 (popw ,tn bignum-digits-offset other-pointer-lowtag
)))))
121 (macrolet ((def (reg)
122 (let ((tn (symbolicate reg
"-TN")))
123 `(define-assembly-routine (,(symbolicate "ALLOC-UNSIGNED-BIGNUM-IN-" reg
)) ()
125 ;; Sign flag is set by the caller! Note: The inline
126 ;; version always allocates space for two words, but
127 ;; here we minimize garbage.
128 (inst jmp
:ns one-word-bignum
)
130 (alloc-other ,tn bignum-widetag
(+ bignum-digits-offset
2) nil
)
131 (popw ,tn bignum-digits-offset other-pointer-lowtag
)
134 (alloc-other ,tn bignum-widetag
(+ bignum-digits-offset
1) nil
)
135 (popw ,tn bignum-digits-offset other-pointer-lowtag
)))))
144 (define-assembly-routine (alloc-tls-index
145 (:translate ensure-symbol-tls-index
)
146 (:result-types positive-fixnum
)
147 (:policy
:fast-safe
))
148 ;; The vop result is unsigned-reg because the assembly routine does not
149 ;; fixnumize its answer, which is confusing because it looks like a fixnum.
150 ;; But the result of the function ENSURE-SYMBOL-TLS-INDEX is a fixnum whose
151 ;; value in Lisp is the number that the assembly code computes,
152 ;; *not* the fixnum whose representation it computes.
153 ((:arg symbol
(descriptor-reg) eax-offset
) ; both input and output
154 (:res result
(unsigned-reg) eax-offset
))
155 (let ((scratch-reg ecx-tn
) ; ECX gets callee-saved, not declared as a temp
156 (free-tls-index-ea (make-ea-for-symbol-value *free-tls-index
*))
157 (lock-bit 31) ; sign bit
158 (tls-full (gen-label)))
159 ;; A pseudo-atomic section avoids bad behavior if the current thread were
160 ;; to receive an interrupt causing it to do a slow operation between
161 ;; acquisition and release of the spinlock. Preventing GC is irrelevant,
162 ;; but would not be if we recycled tls indices of garbage symbols.
164 (assemble () ; for conversion of tagbody-like labels to assembler labels
166 (inst bts free-tls-index-ea lock-bit
:lock
)
167 (inst jmp
:nc got-tls-index-lock
)
168 (inst pause
) ; spin loop hint
169 ;; TODO: yielding the CPU here might be a good idea
172 ;; Now we hold the spinlock. With it held, see if the symbol's
173 ;; tls-index has been set in the meantime.
174 (inst cmp
(tls-index-of symbol
) 0)
175 (inst jmp
:e new-tls-index
)
176 ;; TLS index is valid, so use it.
177 (inst and
(make-ea :byte
:disp
(+ (ea-disp free-tls-index-ea
) 3)) #x7F
178 :lock
) ; set the spinlock bit to 0
181 ;; Allocate a new tls-index.
182 (inst push scratch-reg
)
183 (inst mov scratch-reg free-tls-index-ea
)
184 (inst and scratch-reg
#x7FFFFFFF
) ; mask off the sign
186 (progn ; need to use another register
188 (inst mov edx-tn
(make-fixup "dynamic_values_bytes" :foreign-dataref
))
189 (inst cmp scratch-reg
(make-ea :dword
:base edx-tn
))
191 #-win32
(inst cmp scratch-reg
192 (make-ea :dword
:disp
(ash thread-tls-size-slot word-shift
)) :fs
)
193 (inst jmp
:ae tls-full
)
194 ;; Assign the tls-index into the symbol
195 (inst mov
(tls-index-of symbol
) scratch-reg
)
196 ;; Bump the free index and clear the lock.
197 (inst add scratch-reg n-word-bytes
)
198 (inst mov free-tls-index-ea scratch-reg
)
199 (inst pop scratch-reg
)
201 (inst mov result
(tls-index-of symbol
)))) ; end PSEUDO-ATOMIC
203 (emit-label tls-full
)
204 (inst mov free-tls-index-ea scratch-reg
) ; unlock
205 (inst pop scratch-reg
) ; balance the stack
206 (%clear-pseudo-atomic
)
207 ;; There's a spurious RET instruction auto-inserted, but no matter.
208 (error-call nil
'tls-exhausted-error
)))