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 ;;;; Notinline allocators
  15 ;;;; Allocate bytes and return the start of the allocated space
  16 ;;;; in the specified destination register.
  17 ;;;;
  18 ;;;; In the general case the size will be in the destination register.
  19 ;;;;
  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.
  23 ;;;;
  24 ;;;; ALLOC factors out the logic of calling alloc(): stack alignment, etc.
  25 #+sb-assembling
  26 (macrolet ((alloc (reg size c-fun)
  27              `(progn
  28                 (inst push ebp-tn)
  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)
  35                 (inst pop 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)))
  41                      ,@body
  42                      ,@(when r3 `((inst pop ,r3)))
  43                      (inst pop ,r2) (inst pop ,r1)))
  44            (alloc-to-reg (reg size &optional (c-fun "alloc"))
  45              (let ((size-calc
  46                      (unless size
  47                        (setq size reg)
  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+)
  52                                  :fs)
  53                            (inst sub ,reg (make-ea :dword :disp (ash thread-mixed-tlab-slot 2)
  54                                                           :base ,scratch-tn))))
  55                        #-win32
  56                        `(#+sb-thread (inst sub ,reg
  57                                            (make-ea :dword :disp (ash thread-mixed-tlab-slot 2))
  58                                            :fs)
  59                          #-sb-thread (inst sub ,reg
  60                                            (make-ea :dword :disp
  61                                                     (+ static-space-start mixed-region-offset)))))))
  62              (case reg
  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)))
  75              `(progn
  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)) ()
  88                   (alloc-to-reg ,tn 8))
  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))
  97
  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.
 102
 103 ;;; #+SB-ASSEMBLING as we don't need VOPS, just the asm routines:
 104 ;;; these are out-of-line versions called by VOPs.
 105
 106 #+sb-assembling
 107 (macrolet ((def (reg)
 108              (let ((tn (symbolicate reg "-TN")))
 109                `(define-assembly-routine (,(symbolicate "ALLOC-SIGNED-BIGNUM-IN-" reg)) ()
 110                   (inst push ,tn)
 111                   (alloc-other ,tn bignum-widetag (+ bignum-digits-offset 1) nil)
 112                   (popw ,tn bignum-digits-offset other-pointer-lowtag)))))
 113   (def eax)
 114   (def ebx)
 115   (def ecx)
 116   (def edx)
 117   (def edi)
 118   (def esi))
 119
 120 #+sb-assembling
 121 (macrolet ((def (reg)
 122              (let ((tn (symbolicate reg "-TN")))
 123                `(define-assembly-routine (,(symbolicate "ALLOC-UNSIGNED-BIGNUM-IN-" reg)) ()
 124                   (inst push ,tn)
 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)
 129                   ;; Two word bignum
 130                   (alloc-other ,tn bignum-widetag (+ bignum-digits-offset 2) nil)
 131                   (popw ,tn bignum-digits-offset other-pointer-lowtag)
 132                   (inst ret)
 133                   ONE-WORD-BIGNUM
 134                   (alloc-other ,tn bignum-widetag (+ bignum-digits-offset 1) nil)
 135                   (popw ,tn bignum-digits-offset other-pointer-lowtag)))))
 136   (def eax)
 137   (def ebx)
 138   (def ecx)
 139   (def edx)
 140   (def edi)
 141   (def esi))
 142
 143 #+sb-thread
 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.
 163     (pseudo-atomic ()
 164      (assemble () ; for conversion of tagbody-like labels to assembler labels
 165      RETRY
 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
 170        (inst jmp retry)
 171      GOT-TLS-INDEX-LOCK
 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
 179        (inst jmp done)
 180      NEW-TLS-INDEX
 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
 185        #+win32
 186        (progn ; need to use another register
 187          (inst push edx-tn)
 188          (inst mov edx-tn (make-fixup "dynamic_values_bytes" :foreign-dataref))
 189          (inst cmp scratch-reg (make-ea :dword :base edx-tn))
 190          (inst pop 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)
 200      DONE
 201        (inst mov result (tls-index-of symbol)))) ; end PSEUDO-ATOMIC
 202     (inst ret)
 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)))