src/compiler/x86-64/alloc.lisp

   1 ;;;; allocation VOPs for the x86-64
   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 ;;;; CONS, LIST and LIST*
  15 (define-vop (list-or-list*)
  16   (:args (things :more t))
  17   (:temporary (:sc unsigned-reg) ptr temp)
  18   (:temporary (:sc unsigned-reg :to (:result 0) :target result) res)
  19   (:info num)
  20   (:results (result :scs (descriptor-reg)))
  21   (:variant-vars star)
  22   (:policy :safe)
  23   (:node-var node)
  24   (:generator 0
  25     (cond ((zerop num)
  26            ;; (move result nil-value)
  27            (inst mov result nil-value))
  28           ((and star (= num 1))
  29            (move result (tn-ref-tn things)))
  30           (t
  31            (macrolet
  32                ((store-car (tn list &optional (slot cons-car-slot))
  33                   `(let ((reg
  34                           (sc-case ,tn
  35                             ((any-reg descriptor-reg) ,tn)
  36                             ((control-stack)
  37                              (move temp ,tn)
  38                              temp))))
  39                      (storew reg ,list ,slot list-pointer-lowtag))))
  40              (let ((cons-cells (if star (1- num) num))
  41                    (stack-allocate-p (awhen (sb!c::node-lvar node)
  42                                        (sb!c::lvar-dynamic-extent it))))
  43                (maybe-pseudo-atomic stack-allocate-p
  44                 (allocation res (* (pad-data-block cons-size) cons-cells) node
  45                             stack-allocate-p list-pointer-lowtag)
  46                 (move ptr res)
  47                 (dotimes (i (1- cons-cells))
  48                   (store-car (tn-ref-tn things) ptr)
  49                   (setf things (tn-ref-across things))
  50                   (inst add ptr (pad-data-block cons-size))
  51                   (storew ptr ptr (- cons-cdr-slot cons-size)
  52                           list-pointer-lowtag))
  53                 (store-car (tn-ref-tn things) ptr)
  54                 (cond (star
  55                        (setf things (tn-ref-across things))
  56                        (store-car (tn-ref-tn things) ptr cons-cdr-slot))
  57                       (t
  58                        (storew nil-value ptr cons-cdr-slot
  59                                list-pointer-lowtag)))
  60                 (aver (null (tn-ref-across things)))))
  61              (move result res))))))
  62
  63 (define-vop (list list-or-list*)
  64   (:variant nil))
  65
  66 (define-vop (list* list-or-list*)
  67   (:variant t))
  68 \f
  69 ;;;; special-purpose inline allocators
  70
  71 ;;; Special variant of 'storew' which might have a shorter encoding
  72 ;;; when storing to the heap (which starts out zero-filled).
  73 (defun storew* (word object slot lowtag zeroed)
  74   (if (or (not zeroed) (not (typep word '(signed-byte 32))))
  75       (storew word object slot lowtag) ; Possibly use temp-reg-tn
  76       (inst mov
  77             (make-ea (cond ((typep word '(unsigned-byte 8)) :byte)
  78                            ((and (not (logtest word #xff))
  79                                  (typep (ash word -8) '(unsigned-byte 8)))
  80                             ;; Array lengths 128 to 16384 which are multiples of 128
  81                             (setq word (ash word -8))
  82                             (decf lowtag 1) ; increment address by 1
  83                             :byte)
  84                            ((and (not (logtest word #xffff))
  85                                  (typep (ash word -16) '(unsigned-byte 8)))
  86                             ;; etc
  87                             (setq word (ash word -16))
  88                             (decf lowtag 2) ; increment address by 2
  89                             :byte)
  90                            ((typep word '(unsigned-byte 16)) :word)
  91                            ;; Definitely a (signed-byte 32) due to pre-test.
  92                            (t :dword))
  93                      :base object
  94                      :disp (- (* slot n-word-bytes) lowtag))
  95             word)))
  96
  97 ;;; ALLOCATE-VECTOR
  98 (macrolet ((calc-size-in-bytes (n-words result-tn)
  99              `(cond ((sc-is ,n-words immediate)
 100                      (pad-data-block (+ (tn-value ,n-words) vector-data-offset)))
 101                     (t
 102                      (inst lea ,result-tn
 103                            (make-ea :byte :index ,n-words
 104                                           :scale (ash 1 (- word-shift n-fixnum-tag-bits))
 105                                           :disp (+ lowtag-mask
 106                                                    (* vector-data-offset n-word-bytes))))
 107                      (inst and ,result-tn (lognot lowtag-mask))
 108                      ,result-tn)))
 109            (put-header (vector-tn type length zeroed)
 110              `(progn (storew* (if (sc-is ,type immediate) (tn-value ,type) ,type)
 111                               ,vector-tn 0 other-pointer-lowtag ,zeroed)
 112                      (storew* (if (sc-is ,length immediate)
 113                                   (fixnumize (tn-value ,length))
 114                                   ,length)
 115                               ,vector-tn vector-length-slot other-pointer-lowtag
 116                               ,zeroed))))
 117
 118   (define-vop (allocate-vector-on-heap)
 119     (:args (type :scs (unsigned-reg immediate))
 120            (length :scs (any-reg immediate))
 121            (words :scs (any-reg immediate)))
 122     (:results (result :scs (descriptor-reg) :from :load))
 123     (:arg-types positive-fixnum positive-fixnum positive-fixnum)
 124     (:policy :fast-safe)
 125     (:generator 100
 126       ;; The LET generates instructions that needn't be pseudoatomic
 127       ;; so don't move it inside.
 128       (let ((size (calc-size-in-bytes words result)))
 129         (pseudo-atomic
 130          (allocation result size nil nil other-pointer-lowtag)
 131          (put-header result type length t)))))
 132
 133   (define-vop (allocate-vector-on-stack)
 134     (:args (type :scs (unsigned-reg immediate) :to :save)
 135            (length :scs (any-reg immediate) :to :eval :target rax)
 136            (words :scs (any-reg immediate) :target rcx))
 137     (:temporary (:sc any-reg :offset ecx-offset :from (:argument 2)) rcx)
 138     (:temporary (:sc any-reg :offset eax-offset :from :eval) rax)
 139     (:temporary (:sc any-reg :offset edi-offset) rdi)
 140     (:temporary (:sc complex-double-reg) zero)
 141     (:results (result :scs (descriptor-reg) :from :load))
 142     (:arg-types positive-fixnum positive-fixnum positive-fixnum)
 143     (:translate allocate-vector)
 144     (:policy :fast-safe)
 145     (:node-var node)
 146     (:generator 100
 147       (let ((size (calc-size-in-bytes words result)))
 148         (allocation result size node t other-pointer-lowtag)
 149         (put-header result type length nil)
 150         ;; FIXME: It would be good to check for stack overflow here.
 151         ;; It would also be good to skip zero-fill of specialized vectors
 152         ;; perhaps in a policy-dependent way. At worst you'd see random
 153         ;; bits, and CLHS says consequences are undefined.
 154         (let ((data-addr
 155                 (make-ea :qword :base result
 156                                 :disp (- (* vector-data-offset n-word-bytes)
 157                                          other-pointer-lowtag))))
 158           (block zero-fill
 159             (cond ((sc-is words immediate)
 160                    (let ((n (tn-value words)))
 161                      (cond ((> n 8)
 162                             (inst mov rcx (tn-value words)))
 163                            ((= n 1)
 164                             (zeroize rax)
 165                             (inst mov data-addr rax)
 166                             (return-from zero-fill))
 167                            (t
 168                             (multiple-value-bind (double single) (truncate n 2)
 169                               (inst xorpd zero zero)
 170                               (dotimes (i double)
 171                                 (inst movapd data-addr zero)
 172                                 (setf data-addr (copy-structure data-addr))
 173                                 (incf (ea-disp data-addr) (* n-word-bytes 2)))
 174                               (unless (zerop single)
 175                                 (inst movaps data-addr zero))
 176                               (return-from zero-fill))))))
 177                   (t
 178                    (move rcx words)
 179                    (inst shr rcx n-fixnum-tag-bits)))
 180             (inst lea rdi data-addr)
 181             (inst cld)
 182             (zeroize rax)
 183             (inst rep)
 184             (inst stos rax)))))))
 185
 186 ;;; ALLOCATE-LIST
 187 (macrolet ((calc-size-in-bytes (length answer)
 188              `(cond ((sc-is ,length immediate)
 189                      (aver (/= (tn-value ,length) 0))
 190                      (* (tn-value ,length) n-word-bytes 2))
 191                     (t
 192                      (inst mov result nil-value)
 193                      (inst test ,length ,length)
 194                      (inst jmp :z done)
 195                      (inst lea ,answer
 196                            (make-ea :byte :base nil :index ,length
 197                                     :scale (ash 1 (1+ (- word-shift
 198                                                          n-fixnum-tag-bits)))))
 199                      ,answer)))
 200            (compute-end ()
 201              `(let ((size (cond ((or (not (fixnump size))
 202                                      (immediate32-p size))
 203                                  size)
 204                                 (t
 205                                  (inst mov limit size)
 206                                  limit))))
 207                 (inst lea limit
 208                       (make-ea :qword :base result
 209                                       :index (if (fixnump size) nil size)
 210                                       :disp (if (fixnump size) size 0))))))
 211
 212   (define-vop (allocate-list-on-stack)
 213     (:args (length :scs (any-reg immediate))
 214            (element :scs (any-reg descriptor-reg)))
 215     (:results (result :scs (descriptor-reg) :from :load))
 216     (:arg-types positive-fixnum *)
 217     (:policy :fast-safe)
 218     (:node-var node)
 219     (:temporary (:sc descriptor-reg) tail next limit)
 220     (:node-var node)
 221     (:generator 20
 222       (let ((size (calc-size-in-bytes length next))
 223             (loop (gen-label)))
 224         (allocation result size node t list-pointer-lowtag)
 225         (compute-end)
 226         (inst mov next result)
 227         (emit-label LOOP)
 228         (inst mov tail next)
 229         (inst add next (* 2 n-word-bytes))
 230         (storew element tail cons-car-slot list-pointer-lowtag)
 231         ;; Store the CDR even if it will be smashed to nil.
 232         (storew next tail cons-cdr-slot list-pointer-lowtag)
 233         (inst cmp next limit)
 234         (inst jmp :ne loop)
 235         (storew nil-value tail cons-cdr-slot list-pointer-lowtag))
 236       done))
 237
 238   (define-vop (allocate-list-on-heap)
 239     (:args (length :scs (any-reg immediate))
 240            (element :scs (any-reg descriptor-reg)
 241                     :load-if (not (and (sc-is element immediate)
 242                                        (eql (tn-value element) 0)))))
 243     (:results (result :scs (descriptor-reg) :from :load))
 244     (:arg-types positive-fixnum *)
 245     (:policy :fast-safe)
 246     (:node-var node)
 247     (:temporary (:sc descriptor-reg) tail next limit)
 248     (:generator 20
 249       (let ((size (calc-size-in-bytes length next))
 250             (entry (gen-label))
 251             (loop (gen-label))
 252             (no-init
 253              (and (sc-is element immediate) (eql (tn-value element) 0))))
 254         (pseudo-atomic
 255          (allocation result size node nil list-pointer-lowtag)
 256          (compute-end)
 257          (inst mov next result)
 258          (inst jmp entry)
 259          (emit-label LOOP)
 260          (storew next tail cons-cdr-slot list-pointer-lowtag)
 261          (emit-label ENTRY)
 262          (inst mov tail next)
 263          (inst add next (* 2 n-word-bytes))
 264          (unless no-init ; don't bother writing zeros in the CARs
 265            (storew element tail cons-car-slot list-pointer-lowtag))
 266          (inst cmp next limit)
 267          (inst jmp :ne loop))
 268         (storew nil-value tail cons-cdr-slot list-pointer-lowtag))
 269       done)))
 270 \f
 271 #!-immobile-space
 272 (define-vop (make-fdefn)
 273   (:policy :fast-safe)
 274   (:translate make-fdefn)
 275   (:args (name :scs (descriptor-reg) :to :eval))
 276   (:results (result :scs (descriptor-reg) :from :argument))
 277   (:node-var node)
 278   (:generator 37
 279     (with-fixed-allocation (result fdefn-widetag fdefn-size node)
 280       (storew name result fdefn-name-slot other-pointer-lowtag)
 281       (storew nil-value result fdefn-fun-slot other-pointer-lowtag)
 282       (storew (make-fixup 'undefined-tramp :assembly-routine)
 283               result fdefn-raw-addr-slot other-pointer-lowtag))))
 284
 285 (define-vop (make-closure)
 286   (:args (function :to :save :scs (descriptor-reg)))
 287   (:info length stack-allocate-p)
 288   (:temporary (:sc any-reg) temp)
 289   (:results (result :scs (descriptor-reg)))
 290   (:node-var node)
 291   (:generator 10
 292    (maybe-pseudo-atomic stack-allocate-p
 293     (let ((size (+ length closure-info-offset)))
 294       (allocation result (pad-data-block size) node stack-allocate-p
 295                   fun-pointer-lowtag)
 296       (storew* (logior (ash (1- size) n-widetag-bits) closure-header-widetag)
 297                result 0 fun-pointer-lowtag (not stack-allocate-p)))
 298     (loadw temp function closure-fun-slot fun-pointer-lowtag)
 299     (storew temp result closure-fun-slot fun-pointer-lowtag))))
 300
 301 ;;; The compiler likes to be able to directly make value cells.
 302 (define-vop (make-value-cell)
 303   (:args (value :scs (descriptor-reg any-reg) :to :result))
 304   (:results (result :scs (descriptor-reg) :from :eval))
 305   (:info stack-allocate-p)
 306   (:node-var node)
 307   (:generator 10
 308     (with-fixed-allocation
 309         (result value-cell-header-widetag value-cell-size node stack-allocate-p)
 310       (storew value result value-cell-value-slot other-pointer-lowtag))))
 311 \f
 312 ;;;; automatic allocators for primitive objects
 313
 314 (define-vop (make-unbound-marker)
 315   (:args)
 316   (:results (result :scs (descriptor-reg any-reg)))
 317   (:generator 1
 318     (inst mov result unbound-marker-widetag)))
 319
 320 (define-vop (make-funcallable-instance-tramp)
 321   (:args)
 322   (:results (result :scs (any-reg)))
 323   (:generator 1
 324     (inst mov result (make-fixup 'funcallable-instance-tramp :assembly-routine))))
 325
 326 (define-vop (fixed-alloc)
 327   (:args)
 328   (:info name words type lowtag stack-allocate-p)
 329   (:ignore name)
 330   (:results (result :scs (descriptor-reg)))
 331   (:node-var node)
 332   (:generator 50
 333     (maybe-pseudo-atomic stack-allocate-p
 334      (allocation result (pad-data-block words) node stack-allocate-p lowtag)
 335      (when type
 336        (storew* (logior (ash (1- words) n-widetag-bits) type)
 337                 result 0 lowtag (not stack-allocate-p))))))
 338
 339 (define-vop (var-alloc)
 340   (:args (extra :scs (any-reg)))
 341   (:arg-types positive-fixnum)
 342   (:info name words type lowtag)
 343   (:ignore name)
 344   (:results (result :scs (descriptor-reg) :from (:eval 1)))
 345   (:temporary (:sc any-reg :from :eval :to (:eval 1)) bytes)
 346   (:temporary (:sc any-reg :from :eval :to :result) header)
 347   (:node-var node)
 348   (:generator 50
 349     (inst lea bytes
 350           (make-ea :qword :disp (* (1+ words) n-word-bytes) :index extra
 351                    :scale (ash 1 (- word-shift n-fixnum-tag-bits))))
 352     (inst mov header bytes)
 353     (inst shl header (- n-widetag-bits word-shift)) ; w+1 to length field
 354     (inst lea header                    ; (w-1 << 8) | type
 355           (make-ea :qword :base header
 356                    :disp (+ (ash -2 n-widetag-bits) type)))
 357     (inst and bytes (lognot lowtag-mask))
 358     (pseudo-atomic
 359      (allocation result bytes node)
 360      (inst lea result (make-ea :byte :base result :disp lowtag))
 361      (storew header result 0 lowtag))))
 362
 363 #!+immobile-space
 364 (macrolet ((def (lisp-name c-name arg-scs &body stuff
 365                            &aux (argc (length arg-scs)))
 366              `(define-vop (,lisp-name)
 367                 (:args ,@(if (>= argc 1) `((arg1 :scs ,(first arg-scs) :target c-arg1)))
 368                        ,@(if (>= argc 2) `((arg2 :scs ,(second arg-scs) :target c-arg2))))
 369                 ,@(if (>= argc 1)
 370                       '((:temporary (:sc unsigned-reg :from (:argument 0)
 371                                      :to :eval :offset rdi-offset) c-arg1)))
 372                 ,@(if (>= argc 2)
 373                       '((:temporary (:sc unsigned-reg :from (:argument 1)
 374                                      :to :eval :offset rsi-offset) c-arg2)))
 375                 (:temporary (:sc unsigned-reg :from :eval :to (:result 0)
 376                              :offset rax-offset) c-result)
 377                 (:results (result :scs (descriptor-reg)))
 378                 (:generator 50
 379                  (pseudo-atomic
 380                   ,@(if (>= argc 1) '((move c-arg1 arg1)))
 381                   ,@(if (>= argc 2) '((move c-arg2 arg2)))
 382                   (inst and rsp-tn -16)
 383                   (inst mov temp-reg-tn (make-fixup ,c-name :foreign))
 384                   (inst call temp-reg-tn)
 385                   ,@stuff
 386                   (move result c-result))))))
 387   ;; These VOPs are each used in one place only, and deliberately not
 388   ;; specified as transforming the function after which they are named.
 389   (def alloc-immobile-layout "alloc_layout" ; MAKE-LAYOUT
 390        ((descriptor-reg) (descriptor-reg)))
 391   (def alloc-immobile-symbol "alloc_sym"    ; MAKE-SYMBOL
 392        ((descriptor-reg) (any-reg)))
 393   (def alloc-immobile-fdefn  "alloc_fdefn"  ; MAKE-FDEFN
 394        ((descriptor-reg)))
 395   )