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                (inst mov target 1)
 104                (inst xor eax-tn eax-tn)
 105                (inst cmpxchg (make-ea-for-symbol-value *tls-index-lock*)
 106                      target :lock)
 107                (inst jmp :ne get-tls-index-lock)
 108                ;; The symbol is now in OTHER.
 109                (inst pop 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 ((not-error (gen-label))
 118                      (error (generate-error-code nil 'tls-exhausted-error)))
 119                  (inst cmp target (fixnumize tls-size))
 120                  (inst jmp :l not-error)
 121                  (%clear-pseudo-atomic)
 122                  (inst jmp error)
 123                  (emit-label not-error))
 124                (inst add (make-ea-for-symbol-value *free-tls-index*)
 125                      (fixnumize 1))
 126                (storew target other symbol-tls-index-slot other-pointer-lowtag)
 127                (emit-label release-tls-index-lock)
 128                ;; No need for barriers on x86/x86-64 on unlock.
 129                (store-symbol-value 0 *tls-index-lock*)
 130                ;; Restore OTHER.
 131                (inst pop other))
 132               (inst ret))))))
 133   (def eax)
 134   (def ebx)
 135   (def ecx)
 136   (def edx)
 137   (def edi)
 138   (def esi))