X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fassembly%2Fx86%2Falloc.lisp;h=3131e454bf523bec6966b2fdec0b7e53967408bb;hb=5728601f88c400d2992b6b8c70d8971d07de9029;hp=a0bac4f8778e9336fd335c6d62d2fe21d169e9db;hpb=a1337bbf6d317b1e7494a73ad4b3c670f69eea4d;p=sbcl.git diff --git a/src/assembly/x86/alloc.lisp b/src/assembly/x86/alloc.lisp index a0bac4f..3131e45 100644 --- a/src/assembly/x86/alloc.lisp +++ b/src/assembly/x86/alloc.lisp @@ -11,69 +11,62 @@ (in-package "SB!VM") -;;;; from signed/unsigned +;;;; Signed and unsigned bignums from word-sized integers. Argument +;;;; and return in the same register. No VOPs, as these are only used +;;;; as out-of-line versions: MOVE-FROM-[UN]SIGNED VOPs handle the +;;;; fixnum cases inline. -;;; KLUDGE: Why don't we want vops for this one and the next -;;; one? -- WHN 19990916 -#+sb-assembling ; We don't want a vop for this one. -(define-assembly-routine - (move-from-signed) - ((:temp eax unsigned-reg eax-offset) - (:temp ebx unsigned-reg ebx-offset)) - (inst mov ebx eax) - (inst shl ebx 1) - (inst jmp :o bignum) - (inst shl ebx 1) - (inst jmp :o bignum) - (inst ret) - BIGNUM +;;; #+SB-ASSEMBLING as we don't need VOPS, just the asm routines: +;;; these are out-of-line versions called by VOPs. - (with-fixed-allocation (ebx bignum-widetag (+ bignum-digits-offset 1)) - (storew eax ebx bignum-digits-offset other-pointer-lowtag)) - - (inst ret)) - -#+sb-assembling ; We don't want a vop for this one either. -(define-assembly-routine - (move-from-unsigned) - ((:temp eax unsigned-reg eax-offset) - (:temp ebx unsigned-reg ebx-offset)) - - (inst test eax #xe0000000) - (inst jmp :nz bignum) - ;; Fixnum - (inst mov ebx eax) - (inst shl ebx 2) - (inst ret) - - BIGNUM - ;;; Note: On the mips port space for a two word bignum is always - ;;; allocated and the header size is set to either one or two words - ;;; as appropriate. On the mips port this is faster, and smaller - ;;; inline, but produces more garbage. The inline x86 version uses - ;;; the same approach, but here we save garbage and allocate the - ;;; smallest possible bignum. - (inst jmp :ns one-word-bignum) - (inst mov ebx eax) - - ;; Two word bignum - (with-fixed-allocation (ebx bignum-widetag (+ bignum-digits-offset 2)) - (storew eax ebx bignum-digits-offset other-pointer-lowtag)) - (inst ret) +#+sb-assembling +(macrolet ((def (reg) + (let ((tn (symbolicate reg "-TN"))) + `(define-assembly-routine (,(symbolicate "ALLOC-SIGNED-BIGNUM-IN-" reg)) () + (inst push ,tn) + (with-fixed-allocation (,tn bignum-widetag (+ bignum-digits-offset 1)) + (popw ,tn bignum-digits-offset other-pointer-lowtag)) + (inst ret))))) + (def eax) + (def ebx) + (def ecx) + (def edx) + (def edi) + (def esi)) - ONE-WORD-BIGNUM - (with-fixed-allocation (ebx bignum-widetag (+ bignum-digits-offset 1)) - (storew eax ebx bignum-digits-offset other-pointer-lowtag)) - (inst ret)) +#+sb-assembling +(macrolet ((def (reg) + (let ((tn (symbolicate reg "-TN"))) + `(define-assembly-routine (,(symbolicate "ALLOC-UNSIGNED-BIGNUM-IN-" reg)) () + (inst push ,tn) + ;; Sign flag is set by the caller! Note: The inline + ;; version always allocates space for two words, but + ;; here we minimize garbage. + (inst jmp :ns one-word-bignum) + ;; Two word bignum + (with-fixed-allocation (,tn bignum-widetag (+ bignum-digits-offset 2)) + (popw ,tn bignum-digits-offset other-pointer-lowtag)) + (inst ret) + ONE-WORD-BIGNUM + (with-fixed-allocation (,tn bignum-widetag (+ bignum-digits-offset 1)) + (popw ,tn bignum-digits-offset other-pointer-lowtag)) + (inst ret))))) + (def eax) + (def ebx) + (def ecx) + (def edx) + (def edi) + (def esi)) +;;; FIXME: This is dead, right? Can it go? #+sb-assembling (defun frob-allocation-assembly-routine (obj lowtag arg-tn) `(define-assembly-routine (,(intern (format nil "ALLOCATE-~A-TO-~A" obj arg-tn))) ((:temp ,arg-tn descriptor-reg ,(intern (format nil "~A-OFFSET" arg-tn)))) (pseudo-atomic (allocation ,arg-tn (pad-data-block ,(intern (format nil "~A-SIZE" obj)))) - (inst lea ,arg-tn (make-ea :byte :base ,arg-tn :disp ,lowtag)) - (inst ret)))) + (inst lea ,arg-tn (make-ea :byte :base ,arg-tn :disp ,lowtag))) + (inst ret))) #+sb-assembling (macrolet ((frob-cons-routines () @@ -85,3 +78,62 @@ (intern (aref *dword-register-names* tn-offset))) routines))))) (frob-cons-routines)) + +#+sb-assembling +(macrolet + ((def (reg) + (declare (ignorable reg)) + #!+sb-thread + (let* ((name (intern (format nil "ALLOC-TLS-INDEX-IN-~A" reg))) + (target-offset (intern (format nil "~A-OFFSET" reg))) + (other-offset (if (eql 'eax reg) + 'ecx-offset + 'eax-offset))) + ;; Symbol starts in TARGET, where the TLS-INDEX ends up in. + `(define-assembly-routine ,name + ((:temp other descriptor-reg ,other-offset) + (:temp target descriptor-reg ,target-offset)) + (let ((get-tls-index-lock (gen-label)) + (release-tls-index-lock (gen-label))) + (pseudo-atomic + ;; Save OTHER & push the symbol. EAX is either one of the two. + (inst push other) + (inst push target) + (emit-label get-tls-index-lock) + (let ((not-eax ,(if (eql 'eax reg) 'other 'target))) + (inst mov not-eax 1) + (inst xor eax-tn eax-tn) + (inst cmpxchg (make-ea-for-symbol-value *tls-index-lock*) + not-eax :lock) + (inst jmp :ne get-tls-index-lock)) + ;; The symbol is now in OTHER. + (inst pop other) + ;; Now with the lock held, see if the symbol's tls index has been + ;; set in the meantime. + (loadw target other symbol-tls-index-slot other-pointer-lowtag) + (inst test target target) + (inst jmp :ne release-tls-index-lock) + ;; Allocate a new tls-index. + (load-symbol-value target *free-tls-index*) + (let ((not-error (gen-label)) + (error (generate-error-code nil 'tls-exhausted-error))) + (inst cmp target (ash tls-size word-shift)) + (inst jmp :l not-error) + (%clear-pseudo-atomic) + (inst jmp error) + (emit-label not-error)) + (inst add (make-ea-for-symbol-value *free-tls-index*) + n-word-bytes) + (storew target other symbol-tls-index-slot other-pointer-lowtag) + (emit-label release-tls-index-lock) + ;; No need for barriers on x86/x86-64 on unlock. + (store-symbol-value 0 *tls-index-lock*) + ;; Restore OTHER. + (inst pop other)) + (inst ret)))))) + (def eax) + (def ebx) + (def ecx) + (def edx) + (def edi) + (def esi))