src/assembly/x86-64/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
  24     ((def (reg)
  25        `(define-assembly-routine (,(symbolicate "ALLOC-SIGNED-BIGNUM-IN-" reg))
  26             ((:temp number unsigned-reg ,(symbolicate reg "-OFFSET")))
  27           (inst push number)
  28           (with-fixed-allocation (number bignum-widetag (+ bignum-digits-offset 1))
  29             (popw number bignum-digits-offset other-pointer-lowtag))
  30           (inst ret))))
  31   (def rax)
  32   (def rcx)
  33   (def rdx)
  34   (def rbx)
  35   (def rsi)
  36   (def rdi)
  37   (def r8)
  38   (def r9)
  39   (def r10)
  40   (def r12)
  41   (def r13)
  42   (def r14)
  43   (def r15))
  44
  45 #+sb-assembling
  46 (macrolet
  47     ((def (reg)
  48        `(define-assembly-routine (,(symbolicate "ALLOC-UNSIGNED-BIGNUM-IN-" reg))
  49             ((:temp number unsigned-reg ,(symbolicate reg "-OFFSET")))
  50           (inst push number)
  51           (inst jmp :ns one-word-bignum)
  52           ;; Two word bignum
  53           (with-fixed-allocation (number bignum-widetag (+ bignum-digits-offset 2))
  54             (popw number bignum-digits-offset other-pointer-lowtag))
  55           (inst ret)
  56           ONE-WORD-BIGNUM
  57           (with-fixed-allocation (number bignum-widetag (+ bignum-digits-offset 1))
  58             (popw number bignum-digits-offset other-pointer-lowtag))
  59           (inst ret))))
  60   (def rax)
  61   (def rcx)
  62   (def rdx)
  63   (def rbx)
  64   (def rsi)
  65   (def rdi)
  66   (def r8)
  67   (def r9)
  68   (def r10)
  69   (def r12)
  70   (def r13)
  71   (def r14)
  72   (def r15))
  73
  74 #+sb-assembling
  75 (macrolet
  76     ((def (reg)
  77        (declare (ignorable reg))
  78        #!+sb-thread
  79        (let* ((name (intern (format nil "ALLOC-TLS-INDEX-IN-~A" reg)))
  80               (target-offset (intern (format nil "~A-OFFSET" reg)))
  81               (other-offset (if (eql 'rax reg)
  82                                 'rcx-offset
  83                                 'rax-offset)))
  84          ;; Symbol starts in TARGET, where the TLS-INDEX ends up in.
  85          `(define-assembly-routine ,name
  86               ((:temp other descriptor-reg ,other-offset)
  87                (:temp target descriptor-reg ,target-offset))
  88             (let ((get-tls-index-lock (gen-label))
  89                   (release-tls-index-lock (gen-label)))
  90               (pseudo-atomic
  91                ;; Save OTHER & push the symbol. RAX is either one of the two.
  92                (inst push other)
  93                (inst push target)
  94                (emit-label get-tls-index-lock)
  95                (let ((not-rax ,(if (eql 'rax reg) 'other 'target)))
  96                  (inst mov not-rax 1)
  97                  (zeroize rax-tn)
  98                  (inst cmpxchg (make-ea-for-symbol-value *tls-index-lock*)
  99                        not-rax :lock)
 100                  (inst jmp :ne get-tls-index-lock))
 101                ;; The symbol is now in OTHER.
 102                (inst pop other)
 103                ;; Now with the lock held, see if the symbol's tls index has been
 104                ;; set in the meantime.
 105                (loadw target other symbol-tls-index-slot other-pointer-lowtag)
 106                (inst or target target)
 107                (inst jmp :ne release-tls-index-lock)
 108                ;; Allocate a new tls-index.
 109                (load-symbol-value target *free-tls-index*)
 110                (let ((not-error (gen-label))
 111                      (error (generate-error-code nil 'tls-exhausted-error)))
 112                  (inst cmp target (fixnumize tls-size))
 113                  (inst jmp :l not-error)
 114                  (%clear-pseudo-atomic)
 115                  (inst jmp error)
 116                  (emit-label not-error))
 117                (inst add (make-ea-for-symbol-value *free-tls-index*)
 118                      (fixnumize 1))
 119                (storew target other symbol-tls-index-slot other-pointer-lowtag)
 120                (emit-label release-tls-index-lock)
 121                ;; No need for barriers on x86/x86-64 on unlock.
 122                (store-symbol-value 0 *tls-index-lock*)
 123                ;; Restore OTHER.
 124                (inst pop other))
 125               (inst ret))))))
 126   (def rax)
 127   (def rcx)
 128   (def rdx)
 129   (def rbx)
 130   (def rsi)
 131   (def rdi)
 132   (def r8)
 133   (def r9)
 134   (def r10)
 135   (def r12)
 136   (def r13)
 137   (def r14)
 138   (def r15))