src/compiler/arm64/macros.lisp

   1 ;;;; a bunch of handy macros for the ARM
   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 ;;; Instruction-like macros.
  15
  16 (defmacro move (dst src)
  17   "Move SRC into DST unless they are location=."
  18   (once-only ((n-dst dst)
  19               (n-src src))
  20     `(unless (location= ,n-dst ,n-src)
  21        (inst mov ,n-dst ,n-src))))
  22
  23 (defmacro move-float (dst src)
  24   (once-only ((n-dst dst)
  25               (n-src src))
  26     `(unless (location= ,n-dst ,n-src)
  27        (inst fmov ,n-dst ,n-src))))
  28
  29 (defmacro move-complex-double (dst src)
  30   (once-only ((n-dst dst)
  31               (n-src src))
  32     `(unless (location= ,n-dst ,n-src)
  33        (inst s-mov ,n-dst ,n-src))))
  34
  35 (defun logical-mask (x)
  36   (cond ((encode-logical-immediate x)
  37          x)
  38         (t
  39          (load-immediate-word tmp-tn x)
  40          tmp-tn)))
  41
  42 (defun load-store-offset (offset &optional (temp tmp-tn) (size 64))
  43   (cond ((ldr-str-offset-encodable offset size)
  44          offset)
  45         (t
  46          (load-immediate-word temp offset)
  47          temp)))
  48
  49 (macrolet
  50     ((def (op inst shift)
  51        `(defmacro ,op (object base
  52                        &optional (offset 0) (lowtag 0))
  53           `(inst ,',inst ,object
  54                  (@ ,base (load-store-offset (- (ash ,offset ,,shift) ,lowtag)))))))
  55   (def loadw ldr word-shift)
  56   (def storew str word-shift))
  57
  58 (defmacro load-symbol (reg symbol)
  59   (once-only ((reg reg) (symbol symbol))
  60     `(inst add ,reg null-tn (add-sub-immediate  (static-symbol-offset ,symbol)))))
  61
  62 (defmacro load-symbol-value (reg symbol)
  63   `(inst ldr ,reg (@ null-tn (load-store-offset (+ (static-symbol-offset ',symbol)
  64                                                    (ash symbol-value-slot word-shift)
  65                                                    (- other-pointer-lowtag))))))
  66
  67 (defmacro store-symbol-value (reg symbol)
  68   `(inst str ,reg
  69          (@ null-tn (load-store-offset (+ (static-symbol-offset ',symbol)
  70                                           (ash symbol-value-slot word-shift)
  71                                           (- other-pointer-lowtag))))))
  72
  73 (defmacro load-type (target source &optional (offset 0))
  74   "Loads the type bits of a pointer into target independent of
  75   byte-ordering issues."
  76   (once-only ((n-target target)
  77               (n-source source)
  78               (n-offset offset))
  79     (let ((target-offset #!+little-endian n-offset
  80                          #!+big-endian `(+ ,n-offset (1- n-word-bytes))))
  81       `(inst ldrb ,n-target (@ ,n-source ,target-offset)))))
  82
  83 ;;; Macros to handle the fact that our stack pointer isn't actually in
  84 ;;; a register (or won't be, by the time we're done).
  85
  86 ;;; Macros to handle the fact that we cannot use the machine native call and
  87 ;;; return instructions.
  88
  89 (defmacro lisp-jump (function lip)
  90   "Jump to the lisp lip LIP."
  91   `(let ((function ,function)
  92          (lip ,lip))
  93      (assert (sc-is lip interior-reg))
  94      (inst add lip function
  95            (- (ash simple-fun-code-offset word-shift)
  96               fun-pointer-lowtag))
  97      (inst br lip)))
  98
  99 (defmacro lisp-return (function lip return-style)
 100   "Return to RETURN-PC."
 101   `(let* ((function ,function)
 102           (lip ,lip))
 103      ;; Indicate a single-valued return by clearing all of the status
 104      ;; flags, or a multiple-valued return by setting all of the status
 105      ;; flags.
 106      (assert (sc-is lip interior-reg))
 107      ,@(ecase return-style
 108          (:single-value '((inst msr :nzcv zr-tn)))
 109          (:multiple-values '((inst orr tmp-tn zr-tn #xf0000000)
 110                              (inst msr :nzcv tmp-tn)))
 111          (:known))
 112      (inst sub lip function (- other-pointer-lowtag 8))
 113      (inst ret lip)))
 114
 115 (defmacro emit-return-pc (label)
 116   "Emit a return-pc header word.  LABEL is the label to use for this return-pc."
 117   `(progn
 118      (emit-alignment n-lowtag-bits)
 119      (emit-label ,label)
 120      (inst lra-header-word)))
 121
 122 \f
 123 ;;;; Stack TN's
 124
 125 ;;; Move a stack TN to a register and vice-versa.
 126 (defun load-stack-offset (reg stack stack-tn)
 127   (inst ldr reg (@ stack (load-store-offset (* (tn-offset stack-tn) n-word-bytes)))))
 128
 129 (defmacro load-stack-tn (reg stack)
 130   `(let ((reg ,reg)
 131          (stack ,stack))
 132      (sc-case stack
 133        ((control-stack)
 134         (load-stack-offset reg cfp-tn stack)))))
 135
 136 (defun store-stack-offset (reg stack stack-tn)
 137   (let ((offset (* (tn-offset stack-tn) n-word-bytes)))
 138     (inst str reg (@ stack (load-store-offset offset)))))
 139
 140 (defmacro store-stack-tn (stack reg)
 141   `(let ((stack ,stack)
 142          (reg ,reg))
 143      (sc-case stack
 144        ((control-stack)
 145         (store-stack-offset reg cfp-tn stack)))))
 146
 147 (defmacro maybe-load-stack-tn (reg reg-or-stack)
 148   "Move the TN Reg-Or-Stack into Reg if it isn't already there."
 149   (once-only ((n-reg reg)
 150               (n-stack reg-or-stack))
 151     `(sc-case ,n-reg
 152        ((any-reg descriptor-reg)
 153         (sc-case ,n-stack
 154           ((any-reg descriptor-reg)
 155            (move ,n-reg ,n-stack))
 156           ((control-stack)
 157            (load-stack-offset ,n-reg cfp-tn ,n-stack)))))))
 158 \f
 159 ;;;; Storage allocation:
 160
 161
 162 ;;; This is the main mechanism for allocating memory in the lisp heap.
 163 ;;;
 164 ;;; The allocated space is stored in RESULT-TN with the lowtag LOWTAG
 165 ;;; applied.  The amount of space to be allocated is SIZE bytes (which
 166 ;;; must be a multiple of the lisp object size).
 167 ;;;
 168 ;;; Each platform seems to have its own slightly different way to do
 169 ;;; heap allocation, taking various different options as parameters.
 170 ;;; For ARM, we take the bare minimum parameters, RESULT-TN, SIZE, and
 171 ;;; LOWTAG, and we require a single temporary register called FLAG-TN
 172 ;;; to emphasize the parallelism with PSEUDO-ATOMIC (which must
 173 ;;; surround a call to ALLOCATION anyway), and to indicate that the
 174 ;;; P-A FLAG-TN is also acceptable here.
 175
 176 #!+gencgc
 177 (defun allocation-tramp (alloc-tn size back-label return-in-tmp lip)
 178   (unless (eq size tmp-tn)
 179     (inst mov tmp-tn size))
 180   (load-inline-constant alloc-tn '(:fixup "alloc_tramp" :foreign) lip)
 181   (inst blr alloc-tn)
 182   (unless return-in-tmp
 183     (move alloc-tn tmp-tn))
 184   (inst b back-label))
 185
 186 (defmacro allocation (result-tn size lowtag &key flag-tn
 187                                                  stack-allocate-p
 188                                                  (lip (if stack-allocate-p
 189                                                           nil
 190                                                           (missing-arg))))
 191   ;; Normal allocation to the heap.
 192   (once-only ((result-tn result-tn)
 193               (size size)
 194               (lowtag lowtag)
 195               (flag-tn flag-tn)
 196               (stack-allocate-p stack-allocate-p)
 197               (lip lip))
 198     `(cond (,stack-allocate-p
 199             (assemble ()
 200               (move ,result-tn csp-tn)
 201               (inst tst ,result-tn lowtag-mask)
 202               (inst b :eq ALIGNED)
 203               (inst add ,result-tn ,result-tn n-word-bytes)
 204               ALIGNED
 205               (inst add csp-tn ,result-tn (add-sub-immediate ,size))
 206               ;; :ne is from TST above, this needs to be done after the
 207               ;; stack pointer has been stored.
 208               (inst b :eq ALIGNED2)
 209               (storew zr-tn ,result-tn -1 0)
 210               ALIGNED2
 211               (when ,lowtag
 212                 (inst add ,result-tn ,result-tn ,lowtag))))
 213            #!-gencgc
 214            (t
 215             (load-symbol-value ,flag-tn *allocation-pointer*)
 216             (inst add ,result-tn ,flag-tn ,lowtag)
 217             (inst add ,flag-tn ,flag-tn (add-sub-immediate ,size))
 218             (store-symbol-value ,flag-tn *allocation-pointer*))
 219            #!+gencgc
 220            (t
 221             (let ((alloc (gen-label))
 222                   (back-from-alloc (gen-label))
 223                   size)
 224               #!-sb-thread
 225               (progn
 226                 (load-inline-constant ,flag-tn '(:fixup "boxed_region" :foreign) ,lip)
 227                 (inst ldp ,result-tn ,flag-tn (@ ,flag-tn)))
 228               #!+sb-thread
 229               (inst ldp ,result-tn ,flag-tn (@ thread-tn
 230                                                (* n-word-bytes thread-alloc-region-slot)))
 231               (setf size (add-sub-immediate ,size))
 232               (inst add ,result-tn ,result-tn size)
 233               (inst cmp ,result-tn ,flag-tn)
 234               (inst b :hi ALLOC)
 235               #!-sb-thread
 236               (progn
 237                 (load-inline-constant ,flag-tn '(:fixup "boxed_region" :foreign) ,lip)
 238                 (storew ,result-tn ,flag-tn))
 239               #!+sb-thread
 240               (storew ,result-tn thread-tn thread-alloc-region-slot)
 241
 242               ;; alloc_tramp uses tmp-tn for returning the result,
 243               ;; save on a move when possible
 244               (inst sub (if ,lowtag
 245                             tmp-tn
 246                             ,result-tn) ,result-tn size)
 247
 248               (emit-label BACK-FROM-ALLOC)
 249               (when ,lowtag
 250                 (inst add ,result-tn tmp-tn ,lowtag))
 251
 252               (assemble (*elsewhere*)
 253                 (emit-label ALLOC)
 254                 (allocation-tramp ,result-tn
 255                                   ,size BACK-FROM-ALLOC
 256                                   ;; see the comment above aboout alloc_tramp
 257                                   (and ,lowtag t)
 258                                   ,lip)))))))
 259
 260 (defmacro with-fixed-allocation ((result-tn flag-tn type-code size
 261                                             &key (lowtag other-pointer-lowtag)
 262                                                  stack-allocate-p
 263                                                  (lip (missing-arg)))
 264                                  &body body)
 265   "Do stuff to allocate an other-pointer object of fixed Size with a single
 266   word header having the specified Type-Code.  The result is placed in
 267   Result-TN, and Temp-TN is a non-descriptor temp (which may be randomly used
 268   by the body.)  The body is placed inside the PSEUDO-ATOMIC, and presumably
 269   initializes the object."
 270   (once-only ((result-tn result-tn) (flag-tn flag-tn)
 271               (type-code type-code) (size size) (lowtag lowtag)
 272               (stack-allocate-p stack-allocate-p)
 273               (lip lip))
 274     `(pseudo-atomic (,flag-tn)
 275        (allocation ,result-tn (pad-data-block ,size) ,lowtag
 276                    :flag-tn ,flag-tn
 277                    :stack-allocate-p ,stack-allocate-p
 278                    :lip ,lip)
 279        (when ,type-code
 280          (inst mov ,flag-tn (ash (1- ,size) n-widetag-bits))
 281          (inst add ,flag-tn ,flag-tn ,type-code)
 282          (storew ,flag-tn ,result-tn 0 ,lowtag))
 283        ,@body)))
 284 \f
 285 ;;;; Error Code
 286 (defun emit-error-break (vop kind code values)
 287   (assemble ()
 288     (when vop
 289       (note-this-location vop :internal-error))
 290     ;; Encode both kind and code as an argument to BRK
 291     (inst brk (dpb code (byte 8 8) kind))
 292     ;; NARGS is implicitely assumed for invalid-arg-count
 293     (unless (= kind invalid-arg-count-trap)
 294      (with-adjustable-vector (vector)
 295        (dolist (tn values)
 296          (write-var-integer (make-sc-offset (sc-number (tn-sc tn))
 297                                             (or (tn-offset tn) 0))
 298                             vector))
 299        (inst byte (length vector))
 300        (dotimes (i (length vector))
 301          (inst byte (aref vector i)))
 302        (emit-alignment 2)))))
 303
 304 (defun error-call (vop error-code &rest values)
 305   #!+sb-doc
 306   "Cause an error.  ERROR-CODE is the error to cause."
 307   (emit-error-break vop error-trap (error-number-or-lose error-code) values))
 308
 309 (defun generate-error-code (vop error-code &rest values)
 310   #!+sb-doc
 311   "Generate-Error-Code Error-code Value*
 312   Emit code for an error with the specified Error-Code and context Values."
 313   (assemble (*elsewhere*)
 314     (let ((start-lab (gen-label)))
 315       (emit-label start-lab)
 316       (emit-error-break vop
 317                         (if (eq error-code 'invalid-arg-count-error)
 318                             invalid-arg-count-trap
 319                             error-trap)
 320                         (error-number-or-lose error-code) values)
 321       start-lab)))
 322 \f
 323 ;;;; PSEUDO-ATOMIC
 324
 325
 326 ;;; handy macro for making sequences look atomic
 327 (defmacro pseudo-atomic ((flag-tn) &body forms)
 328   `(progn
 329      (without-scheduling ()
 330        #!-sb-thread
 331        (store-symbol-value csp-tn *pseudo-atomic-atomic*)
 332        #!+sb-thread
 333        (inst str (32-bit-reg null-tn)
 334              (@ thread-tn
 335                 (* n-word-bytes thread-pseudo-atomic-bits-slot))))
 336      (assemble ()
 337        ,@forms)
 338      (without-scheduling ()
 339        #!-sb-thread
 340        (progn
 341          (store-symbol-value null-tn *pseudo-atomic-atomic*)
 342          (load-symbol-value ,flag-tn *pseudo-atomic-interrupted*))
 343        #!+sb-thread
 344        (progn
 345          (inst dmb)
 346          (inst str (32-bit-reg zr-tn)
 347                (@ thread-tn
 348                   (* n-word-bytes thread-pseudo-atomic-bits-slot)))
 349          (inst ldr (32-bit-reg ,flag-tn)
 350                (@ thread-tn
 351                   (+ (* n-word-bytes thread-pseudo-atomic-bits-slot) 4))))
 352        (let ((not-interrputed (gen-label)))
 353          (inst cbz ,flag-tn not-interrputed)
 354          (inst brk pending-interrupt-trap)
 355          (emit-label not-interrputed)))))
 356 \f
 357 ;;;; memory accessor vop generators
 358
 359 (defmacro define-full-reffer (name type offset lowtag scs el-type
 360                               &optional translate)
 361   `(define-vop (,name)
 362      ,@(when translate
 363              `((:translate ,translate)))
 364      (:policy :fast-safe)
 365      (:args (object :scs (descriptor-reg))
 366             (index :scs (any-reg)))
 367      (:arg-types ,type tagged-num)
 368      (:temporary (:scs (interior-reg)) lip)
 369      (:results (value :scs ,scs))
 370      (:result-types ,el-type)
 371      (:generator 5
 372        (inst add lip object (lsl index (- word-shift n-fixnum-tag-bits)))
 373        (loadw value lip ,offset ,lowtag))))
 374
 375 (defmacro define-full-setter (name type offset lowtag scs el-type
 376                               &optional translate)
 377   `(define-vop (,name)
 378      ,@(when translate
 379              `((:translate ,translate)))
 380      (:policy :fast-safe)
 381      (:args (object :scs (descriptor-reg))
 382             (index :scs (any-reg))
 383             (value :scs ,scs :target result))
 384      (:arg-types ,type tagged-num ,el-type)
 385      (:temporary (:scs (interior-reg)) lip)
 386      (:results (result :scs ,scs))
 387      (:result-types ,el-type)
 388      (:generator 2
 389        (inst add lip object (lsl index (- word-shift n-fixnum-tag-bits)))
 390        (storew value lip ,offset ,lowtag)
 391        (move result value))))
 392
 393 (defmacro define-partial-reffer (name type size signed offset lowtag scs
 394                                  el-type &optional translate)
 395   `(define-vop (,name)
 396      ,@(when translate
 397              `((:translate ,translate)))
 398      (:policy :fast-safe)
 399      (:args (object :scs (descriptor-reg))
 400             (index :scs (unsigned-reg)))
 401      (:arg-types ,type positive-fixnum)
 402      (:results (value :scs ,scs))
 403      (:result-types ,el-type)
 404      (:temporary (:scs (interior-reg)) lip)
 405      (:generator 5
 406        ,@(ecase size (eq size :byte)
 407                (:byte
 408                 `((inst add lip object index)
 409                   (inst ,(if signed 'ldrsb 'ldrb)
 410                         value (@ lip (- (* ,offset n-word-bytes) ,lowtag)))))
 411                (:short
 412                 `((inst add lip object (lsl index 1))
 413                   (inst ,(if signed 'ldrsh 'ldrh)
 414                         value (@ lip (- (* ,offset n-word-bytes) ,lowtag)))))
 415                (:word
 416                 `((inst add lip object (lsl index 2))
 417                   (inst ,(if signed 'ldrsw 'ldr) (32-bit-reg value)
 418                         (@ lip (- (* ,offset n-word-bytes) ,lowtag)))))))))
 419
 420 (defmacro define-partial-setter (name type size offset lowtag scs el-type
 421                                  &optional translate)
 422   `(define-vop (,name)
 423      ,@(when translate
 424              `((:translate ,translate)))
 425      (:policy :fast-safe)
 426      (:args (object :scs (descriptor-reg))
 427             (index :scs (unsigned-reg))
 428             (value :scs ,scs :target result))
 429      (:arg-types ,type positive-fixnum ,el-type)
 430      (:temporary (:scs (interior-reg)) lip)
 431      (:results (result :scs ,scs))
 432      (:result-types ,el-type)
 433      (:generator 5
 434        ,@(ecase size (eq size :byte)
 435                 (:byte
 436                  `((inst add lip object index)
 437                    (inst strb value (@ lip (- (* ,offset n-word-bytes) ,lowtag)))))
 438                 (:short
 439                  `((inst add lip object (lsl index 1))
 440                    (inst strh value (@ lip (- (* ,offset n-word-bytes) ,lowtag)))))
 441                 (:word
 442                  `((inst add lip object (lsl index 2))
 443                    (inst str (32-bit-reg value) (@ lip (- (* ,offset n-word-bytes) ,lowtag))))))
 444        (move result value))))
 445
 446 (sb!xc:defmacro with-pinned-objects ((&rest objects) &body body)
 447   "Arrange with the garbage collector that the pages occupied by
 448 OBJECTS will not be moved in memory for the duration of BODY.
 449 Useful for e.g. foreign calls where another thread may trigger
 450 garbage collection.  This is currently implemented by disabling GC"
 451   #!-gencgc
 452   (declare (ignore objects))            ; should we eval these for side-effect?
 453   #!-gencgc
 454   `(without-gcing
 455     ,@body)
 456   #!+gencgc
 457   `(let ((*pinned-objects* (list* ,@objects *pinned-objects*)))
 458      (declare (truly-dynamic-extent *pinned-objects*))
 459      ,@body))
 460
 461 (defun load-inline-constant (dst value &optional lip)
 462   (destructuring-bind (size . label) (register-inline-constant value)
 463     (ecase size
 464       (:qword
 465        (inst load-from-label dst label lip)))))
 466
 467 ;;;
 468
 469 (defmacro load-binding-stack-pointer (reg)
 470   #!+sb-thread `(loadw ,reg thread-tn thread-binding-stack-pointer-slot)
 471   #!-sb-thread `(load-symbol-value ,reg *binding-stack-pointer*))
 472
 473 (defmacro store-binding-stack-pointer (reg)
 474   #!+sb-thread `(storew ,reg thread-tn thread-binding-stack-pointer-slot)
 475   #!-sb-thread `(store-symbol-value ,reg *binding-stack-pointer*))
 476
 477 #!+sb-thread
 478 (defmacro tls-index-of (sym)
 479   `(@ ,sym (- #!+little-endian 4 other-pointer-lowtag)))
 480
 481 (defmacro load-tl-symbol-value (reg symbol)
 482   #!+sb-thread
 483   `(let ((reg ,reg))
 484      (load-symbol tmp-tn ',symbol)
 485      (inst ldr tmp-tn (tls-index-of tmp-tn))
 486      (inst ldr reg (@ thread-tn tmp-tn)))
 487   #!-sb-thread
 488   `(load-symbol-value ,reg ,symbol))
 489
 490 (defmacro store-tl-symbol-value (reg symbol)
 491   #!+sb-thread
 492   `(let ((reg ,reg))
 493      (load-symbol tmp-tn ',symbol)
 494      (inst ldr tmp-tn (tls-index-of tmp-tn))
 495      (inst str reg (@ thread-tn tmp-tn)))
 496   #!-sb-thread
 497   `(store-symbol-value ,reg ,symbol))