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 (defmacro load-stack-tn (reg stack &optional (predicate :al))
 135   `(let ((reg ,reg)
 136          (stack ,stack))
 137      (let ((offset (tn-offset stack)))
 138        (sc-case stack
 139          ((control-stack)
 140           (loadw reg cfp-tn offset 0 ,predicate))))))
 141 (defmacro store-stack-tn (stack reg &optional (predicate :al))
 142   `(let ((stack ,stack)
 143          (reg ,reg))
 144      (let ((offset (tn-offset stack)))
 145        (sc-case stack
 146          ((control-stack)
 147           (storew reg cfp-tn offset 0 ,predicate))))))
 148
 149 (defmacro maybe-load-stack-tn (reg reg-or-stack)
 150   "Move the TN Reg-Or-Stack into Reg if it isn't already there."
 151   (once-only ((n-reg reg)
 152               (n-stack reg-or-stack))
 153     `(sc-case ,n-reg
 154        ((any-reg descriptor-reg)
 155         (sc-case ,n-stack
 156           ((any-reg descriptor-reg)
 157            (move ,n-reg ,n-stack))
 158           ((control-stack)
 159            (loadw ,n-reg cfp-tn (tn-offset ,n-stack))))))))
 160 \f
 161 ;;;; Storage allocation:
 162
 163
 164 ;;; This is the main mechanism for allocating memory in the lisp heap.
 165 ;;;
 166 ;;; The allocated space is stored in RESULT-TN with the lowtag LOWTAG
 167 ;;; applied.  The amount of space to be allocated is SIZE bytes (which
 168 ;;; must be a multiple of the lisp object size).
 169 ;;;
 170 ;;; Each platform seems to have its own slightly different way to do
 171 ;;; heap allocation, taking various different options as parameters.
 172 ;;; For ARM, we take the bare minimum parameters, RESULT-TN, SIZE, and
 173 ;;; LOWTAG, and we require a single temporary register called FLAG-TN
 174 ;;; to emphasize the parallelism with PSEUDO-ATOMIC (which must
 175 ;;; surround a call to ALLOCATION anyway), and to indicate that the
 176 ;;; P-A FLAG-TN is also acceptable here.
 177
 178 (defmacro allocation (result-tn size lowtag &key flag-tn)
 179   ;; Normal allocation to the heap.
 180   (let ((alloc-size (gensym)))
 181     `(let ((,alloc-size ,size))
 182        (load-symbol-value ,flag-tn *allocation-pointer*)
 183        (inst add ,result-tn ,flag-tn ,lowtag)
 184        (inst add ,flag-tn ,flag-tn ,alloc-size)
 185        (store-symbol-value ,flag-tn *allocation-pointer*))))
 186
 187 (defmacro with-fixed-allocation ((result-tn flag-tn type-code size
 188                                             &key (lowtag other-pointer-lowtag))
 189                                  &body body)
 190   "Do stuff to allocate an other-pointer object of fixed Size with a single
 191   word header having the specified Type-Code.  The result is placed in
 192   Result-TN, and Temp-TN is a non-descriptor temp (which may be randomly used
 193   by the body.)  The body is placed inside the PSEUDO-ATOMIC, and presumably
 194   initializes the object."
 195   (once-only ((result-tn result-tn) (flag-tn flag-tn)
 196               (type-code type-code) (size size) (lowtag lowtag))
 197     `(pseudo-atomic (,flag-tn)
 198        (allocation ,result-tn (pad-data-block ,size) ,lowtag
 199                    :flag-tn ,flag-tn)
 200        (when ,type-code
 201          (inst mov ,flag-tn (ash (1- ,size) n-widetag-bits))
 202          (inst orr ,flag-tn ,flag-tn ,type-code)
 203          (storew ,flag-tn ,result-tn 0 ,lowtag))
 204        ,@body)))
 205 \f
 206 ;;;; Error Code
 207 (defun emit-error-break (vop kind code values)
 208   (assemble ()
 209     (when vop
 210       (note-this-location vop :internal-error))
 211     ;; Use the magic officially-undefined instruction that Linux
 212     ;; treats as generating SIGTRAP.
 213     (inst debug-trap)
 214     ;; The rest of this is "just" the encoded error details.
 215     (inst byte kind)
 216     (with-adjustable-vector (vector)
 217       (write-var-integer code vector)
 218       (dolist (tn values)
 219         (write-var-integer (make-sc-offset (sc-number (tn-sc tn))
 220                                            (or (tn-offset tn) 0))
 221                            vector))
 222       (inst byte (length vector))
 223       (dotimes (i (length vector))
 224         (inst byte (aref vector i)))
 225       (emit-alignment word-shift))))
 226
 227 (defun error-call (vop error-code &rest values)
 228   #!+sb-doc
 229   "Cause an error.  ERROR-CODE is the error to cause."
 230   (emit-error-break vop error-trap (error-number-or-lose error-code) values))
 231
 232 (defun generate-error-code (vop error-code &rest values)
 233   #!+sb-doc
 234   "Generate-Error-Code Error-code Value*
 235   Emit code for an error with the specified Error-Code and context Values."
 236   (assemble (*elsewhere*)
 237     (let ((start-lab (gen-label)))
 238       (emit-label start-lab)
 239       (emit-error-break vop error-trap (error-number-or-lose error-code) values)
 240       start-lab)))
 241 \f
 242 ;;;; PSEUDO-ATOMIC
 243
 244 ;;; handy macro for making sequences look atomic
 245 ;;;
 246 ;;; FLAG-TN must be wired to R7.  If a deferred interrupt happens
 247 ;;; while we have *PSEUDO-ATOMIC* set to non-nil, then
 248 ;;; *PSEUDO-ATOMIC-INTERRUPTED* will be changed from NIL to the fixnum
 249 ;;; #x000f0001 (so, #x003c0004), which is the syscall number for
 250 ;;; BREAK_POINT.  This value is less than #x0800000b (NIL).  The
 251 ;;; runtime "knows" that an SWI with a condition code of :LT instead
 252 ;;; of the normal :AL is a pseudo-atomic interrupted trap.
 253 (defmacro pseudo-atomic ((flag-tn) &body forms)
 254   `(progn
 255      (aver (and (sc-is ,flag-tn non-descriptor-reg)
 256                 (= (tn-offset ,flag-tn) 7)))
 257      (without-scheduling ()
 258        (store-symbol-value pc-tn *pseudo-atomic-atomic*))
 259      (assemble ()
 260        ,@forms)
 261      (without-scheduling ()
 262        (store-symbol-value null-tn *pseudo-atomic-atomic*)
 263        (load-symbol-value ,flag-tn *pseudo-atomic-interrupted*)
 264        (inst cmp ,flag-tn null-tn)
 265        (inst mov :lt ,flag-tn (lsr ,flag-tn n-fixnum-tag-bits))
 266        (inst swi :lt 0))))
 267 \f
 268 ;;;; memory accessor vop generators
 269
 270 (defmacro define-full-reffer (name type offset lowtag scs el-type
 271                               &optional translate)
 272   `(define-vop (,name)
 273      ,@(when translate
 274              `((:translate ,translate)))
 275      (:policy :fast-safe)
 276      (:args (object :scs (descriptor-reg))
 277             (index :scs (any-reg)))
 278      (:arg-types ,type tagged-num)
 279      (:temporary (:scs (interior-reg)) lip)
 280      (:results (value :scs ,scs))
 281      (:result-types ,el-type)
 282      (:generator 5
 283        (inst add lip object index)
 284        (loadw value lip ,offset ,lowtag))))
 285
 286 (defmacro define-full-setter (name type offset lowtag scs el-type
 287                               &optional translate)
 288   `(define-vop (,name)
 289      ,@(when translate
 290              `((:translate ,translate)))
 291      (:policy :fast-safe)
 292      (:args (object :scs (descriptor-reg))
 293             (index :scs (any-reg))
 294             (value :scs ,scs :target result))
 295      (:arg-types ,type tagged-num ,el-type)
 296      (:temporary (:scs (interior-reg)) lip)
 297      (:results (result :scs ,scs))
 298      (:result-types ,el-type)
 299      (:generator 2
 300        (inst add lip object index)
 301        (storew value lip ,offset ,lowtag)
 302        (move result value))))
 303
 304 (defmacro define-partial-reffer (name type size signed offset lowtag scs
 305                                  el-type &optional translate)
 306   `(define-vop (,name)
 307      ,@(when translate
 308              `((:translate ,translate)))
 309      (:policy :fast-safe)
 310      (:args (object :scs (descriptor-reg))
 311             (index :scs (unsigned-reg)))
 312      (:arg-types ,type positive-fixnum)
 313      (:results (value :scs ,scs))
 314      (:result-types ,el-type)
 315      (:temporary (:scs (interior-reg)) lip)
 316      (:generator 5
 317        ,(if (eq size :byte)
 318             '(inst add lip object index)
 319             '(inst add lip object (lsl index 1)))
 320        (inst ,(ecase size
 321                      (:byte (if signed 'ldrsb 'ldrb))
 322                      (:short (if signed 'ldrsh 'ldrh)))
 323              value (@ lip (- (* ,offset n-word-bytes) ,lowtag))))))
 324
 325 (defmacro define-partial-setter (name type size offset lowtag scs el-type
 326                                  &optional translate)
 327   `(define-vop (,name)
 328      ,@(when translate
 329              `((:translate ,translate)))
 330      (:policy :fast-safe)
 331      (:args (object :scs (descriptor-reg))
 332             (index :scs (unsigned-reg))
 333             (value :scs ,scs :target result))
 334      (:arg-types ,type positive-fixnum ,el-type)
 335      (:temporary (:scs (interior-reg)) lip)
 336      (:results (result :scs ,scs))
 337      (:result-types ,el-type)
 338      (:generator 5
 339        ,(if (eq size :byte)
 340             '(inst add lip object index)
 341             '(inst add lip object (lsl index 1)))
 342        (inst ,(ecase size (:byte 'strb) (:short 'strh))
 343              value (@ lip (- (* ,offset n-word-bytes) ,lowtag)))
 344        (move result value))))
 345
 346 (def!macro with-pinned-objects ((&rest objects) &body body)
 347   "Arrange with the garbage collector that the pages occupied by
 348 OBJECTS will not be moved in memory for the duration of BODY.
 349 Useful for e.g. foreign calls where another thread may trigger
 350 garbage collection.  This is currently implemented by disabling GC"
 351   (declare (ignore objects))            ;should we eval these for side-effect?
 352   `(without-gcing
 353     ,@body))