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     (inst byte code)
 311     (encode-internal-error-args values)
 312     (emit-alignment word-shift)))
 313
 314 (defun error-call (vop error-code &rest values)
 315   "Cause an error.  ERROR-CODE is the error to cause."
 316   (emit-error-break vop error-trap (error-number-or-lose error-code) values))
 317
 318 (defun generate-error-code (vop error-code &rest values)
 319   "Generate-Error-Code Error-code Value*
 320   Emit code for an error with the specified Error-Code and context Values."
 321   (assemble (*elsewhere*)
 322     (let ((start-lab (gen-label)))
 323       (emit-label start-lab)
 324       (emit-error-break vop error-trap (error-number-or-lose error-code) values)
 325       start-lab)))
 326 \f
 327 ;;;; PSEUDO-ATOMIC
 328
 329
 330 ;;; handy macro for making sequences look atomic
 331
 332 ;;; With LINK being NIL this doesn't store the next PC in LR when
 333 ;;; calling do_pending_interrupt.
 334 ;;; This used by allocate-vector-on-heap, there's a comment explaining
 335 ;;; why it needs that.
 336 (defmacro pseudo-atomic ((flag-tn &key (link t)) &body forms)
 337   `(progn
 338      (without-scheduling ()
 339        (store-symbol-value pc-tn *pseudo-atomic-atomic*))
 340      (assemble ()
 341        ,@forms)
 342      (without-scheduling ()
 343        (store-symbol-value null-tn *pseudo-atomic-atomic*)
 344        (load-symbol-value ,flag-tn *pseudo-atomic-interrupted*)
 345        ;; When *pseudo-atomic-interrupted* is not 0 it contains the address of
 346        ;; do_pending_interrupt
 347        (inst cmp ,flag-tn 0)
 348        ,(if link
 349             `(inst blx :ne ,flag-tn)
 350             `(inst bx :ne ,flag-tn)))))
 351 \f
 352 ;;;; memory accessor vop generators
 353
 354 (defmacro define-full-reffer (name type offset lowtag scs el-type
 355                               &optional translate)
 356   `(define-vop (,name)
 357      ,@(when translate
 358              `((:translate ,translate)))
 359      (:policy :fast-safe)
 360      (:args (object :scs (descriptor-reg))
 361             (index :scs (any-reg)))
 362      (:arg-types ,type tagged-num)
 363      (:temporary (:scs (interior-reg)) lip)
 364      (:results (value :scs ,scs))
 365      (:result-types ,el-type)
 366      (:generator 5
 367        (inst add lip object index)
 368        (loadw value lip ,offset ,lowtag))))
 369
 370 (defmacro define-full-setter (name type offset lowtag scs el-type
 371                               &optional translate)
 372   `(define-vop (,name)
 373      ,@(when translate
 374              `((:translate ,translate)))
 375      (:policy :fast-safe)
 376      (:args (object :scs (descriptor-reg))
 377             (index :scs (any-reg))
 378             (value :scs ,scs :target result))
 379      (:arg-types ,type tagged-num ,el-type)
 380      (:temporary (:scs (interior-reg)) lip)
 381      (:results (result :scs ,scs))
 382      (:result-types ,el-type)
 383      (:generator 2
 384        (inst add lip object index)
 385        (storew value lip ,offset ,lowtag)
 386        (move result value))))
 387
 388 (defmacro define-partial-reffer (name type size signed offset lowtag scs
 389                                  el-type &optional translate)
 390   `(define-vop (,name)
 391      ,@(when translate
 392              `((:translate ,translate)))
 393      (:policy :fast-safe)
 394      (:args (object :scs (descriptor-reg))
 395             (index :scs (unsigned-reg)))
 396      (:arg-types ,type positive-fixnum)
 397      (:results (value :scs ,scs))
 398      (:result-types ,el-type)
 399      (:temporary (:scs (interior-reg)) lip)
 400      (:generator 5
 401        ,(if (eq size :byte)
 402             '(inst add lip object index)
 403             '(inst add lip object (lsl index 1)))
 404        (inst ,(ecase size
 405                      (:byte (if signed 'ldrsb 'ldrb))
 406                      (:short (if signed 'ldrsh 'ldrh)))
 407              value (@ lip (- (* ,offset n-word-bytes) ,lowtag))))))
 408
 409 (defmacro define-partial-setter (name type size offset lowtag scs el-type
 410                                  &optional translate)
 411   `(define-vop (,name)
 412      ,@(when translate
 413              `((:translate ,translate)))
 414      (:policy :fast-safe)
 415      (:args (object :scs (descriptor-reg))
 416             (index :scs (unsigned-reg))
 417             (value :scs ,scs :target result))
 418      (:arg-types ,type positive-fixnum ,el-type)
 419      (:temporary (:scs (interior-reg)) lip)
 420      (:results (result :scs ,scs))
 421      (:result-types ,el-type)
 422      (:generator 5
 423        ,(if (eq size :byte)
 424             '(inst add lip object index)
 425             '(inst add lip object (lsl index 1)))
 426        (inst ,(ecase size (:byte 'strb) (:short 'strh))
 427              value (@ lip (- (* ,offset n-word-bytes) ,lowtag)))
 428        (move result value))))