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