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   (def eax)
  30   (def ebx)
  31   (def ecx)
  32   (def edx)
  33   (def edi)
  34   (def esi))
  35
  36 #+sb-assembling
  37 (macrolet ((def (reg)
  38              (let ((tn (symbolicate reg "-TN")))
  39                `(define-assembly-routine (,(symbolicate "ALLOC-UNSIGNED-BIGNUM-IN-" reg)) ()
  40                   (inst push ,tn)
  41                   ;; Sign flag is set by the caller! Note: The inline
  42                   ;; version always allocates space for two words, but
  43                   ;; here we minimize garbage.
  44                   (inst jmp :ns one-word-bignum)
  45                   ;; Two word bignum
  46                   (with-fixed-allocation (,tn bignum-widetag (+ bignum-digits-offset 2))
  47                     (popw ,tn bignum-digits-offset other-pointer-lowtag))
  48                   (inst ret)
  49                   ONE-WORD-BIGNUM
  50                   (with-fixed-allocation (,tn bignum-widetag (+ bignum-digits-offset 1))
  51                     (popw ,tn bignum-digits-offset other-pointer-lowtag))))))
  52   (def eax)
  53   (def ebx)
  54   (def ecx)
  55   (def edx)
  56   (def edi)
  57   (def esi))
  58
  59 ;;; FIXME: This is dead, right? Can it go?
  60 #+sb-assembling
  61 (defun frob-allocation-assembly-routine (obj lowtag arg-tn)
  62   `(define-assembly-routine (,(intern (format nil "ALLOCATE-~A-TO-~A" obj arg-tn)))
  63      ((:temp ,arg-tn descriptor-reg ,(intern (format nil "~A-OFFSET" arg-tn))))
  64      (pseudo-atomic
  65       (allocation ,arg-tn (pad-data-block ,(intern (format nil "~A-SIZE" obj))))
  66       (inst lea ,arg-tn (make-ea :byte :base ,arg-tn :disp ,lowtag)))))
  67
  68 #+sb-assembling
  69 (macrolet ((frob-cons-routines ()
  70              (let ((routines nil))
  71                (dolist (tn-offset *dword-regs*
  72                         `(progn ,@routines))
  73                  (push (frob-allocation-assembly-routine 'cons
  74                                                          list-pointer-lowtag
  75                                                          (intern (aref +dword-register-names+ tn-offset)))
  76                        routines)))))
  77   (frob-cons-routines))
  78
  79 #!+sb-thread
  80 (define-assembly-routine (alloc-tls-index
  81                           (:translate ensure-symbol-tls-index)
  82                           (:result-types positive-fixnum)
  83                           (:policy :fast-safe))
  84     ;; The vop result is unsigned-reg because the assembly routine does not
  85     ;; fixnumize its answer, which is confusing because it looks like a fixnum.
  86     ;; But the result of the function ENSURE-SYMBOL-TLS-INDEX is a fixnum whose
  87     ;; value in Lisp is the number that the assembly code computes,
  88     ;; *not* the fixnum whose representation it computes.
  89     ((:arg symbol (descriptor-reg) eax-offset) ; both input and output
  90      (:res result (unsigned-reg) eax-offset))
  91   (let ((scratch-reg ecx-tn) ; ECX gets callee-saved, not declared as a temp
  92         (free-tls-index-ea (make-ea-for-symbol-value *free-tls-index*))
  93         (lock-bit 31) ; sign bit
  94         (tls-full (gen-label)))
  95     ;; A pseudo-atomic section avoids bad behavior if the current thread were
  96     ;; to receive an interrupt causing it to do a slow operation between
  97     ;; acquisition and release of the spinlock. Preventing GC is irrelevant,
  98     ;; but would not be if we recycled tls indices of garbage symbols.
  99     (pseudo-atomic
 100      (assemble () ; for conversion of tagbody-like labels to assembler labels
 101      RETRY
 102        (inst bts free-tls-index-ea lock-bit :lock)
 103        (inst jmp :nc got-tls-index-lock)
 104        (inst pause) ; spin loop hint
 105        ;; TODO: yielding the CPU here might be a good idea
 106        (inst jmp retry)
 107      GOT-TLS-INDEX-LOCK
 108        ;; Now we hold the spinlock. With it held, see if the symbol's
 109        ;; tls-index has been set in the meantime.
 110        (inst cmp (tls-index-of symbol) 0)
 111        (inst jmp :e new-tls-index)
 112        ;; TLS index is valid, so use it.
 113        (inst and (make-ea :byte :disp (+ (ea-disp free-tls-index-ea) 3)) #x7F
 114              :lock) ; set the spinlock bit to 0
 115        (inst jmp done)
 116      NEW-TLS-INDEX
 117        ;; Allocate a new tls-index.
 118        (inst push scratch-reg)
 119        (inst mov scratch-reg free-tls-index-ea)
 120        (inst and scratch-reg #x7FFFFFFF) ; mask off the sign
 121        (inst cmp scratch-reg (* tls-size n-word-bytes))
 122        (inst jmp :ae tls-full)
 123        ;; Assign the tls-index into the symbol
 124        (inst mov (tls-index-of symbol) scratch-reg)
 125        ;; Bump the free index and clear the lock.
 126        (inst add scratch-reg n-word-bytes)
 127        (inst mov free-tls-index-ea scratch-reg)
 128        (inst pop scratch-reg)
 129      DONE
 130        (inst mov result (tls-index-of symbol)))) ; end PSEUDO-ATOMIC
 131     (inst ret)
 132     (emit-label tls-full)
 133     (inst mov free-tls-index-ea scratch-reg) ; unlock
 134     (inst pop scratch-reg) ; balance the stack
 135     (%clear-pseudo-atomic)
 136     ;; There's a spurious RET instruction auto-inserted, but no matter.
 137     (error-call nil 'tls-exhausted-error)))