src/compiler/hppa/macros.lisp

   1 ;;;; various useful macros for generating HPPA code
   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 (in-package "SB!VM")
  12
  13 \f
  14
  15 (defmacro expand (expr)
  16   (let ((gensym (gensym)))
  17     `(macrolet
  18        ((,gensym ()
  19            ,expr))
  20        (,gensym))))
  21
  22 ;;; Instruction-like macros.
  23 ;;; FIXME-lav: add if always-emit-code-p is :e= then error if location=
  24 (defmacro move (src dst &optional always-emit-code-p)
  25   #!+sb-doc
  26   "Move SRC into DST (unless they are location= and ALWAYS-EMIT-CODE-P is nil)."
  27   (once-only ((n-src src)
  28               (n-dst dst))
  29     `(if (location= ,n-dst ,n-src)
  30        (when ,always-emit-code-p
  31          (inst nop))
  32        (inst move ,n-src ,n-dst))))
  33
  34 (defmacro loadw (result base &optional (offset 0) (lowtag 0))
  35   (once-only ((result result) (base base))
  36     `(inst ldw (- (ash ,offset word-shift) ,lowtag) ,base ,result)))
  37
  38 (defmacro storew (value base &optional (offset 0) (lowtag 0))
  39   (once-only ((value value) (base base) (offset offset) (lowtag lowtag))
  40     `(inst stw ,value (- (ash ,offset word-shift) ,lowtag) ,base)))
  41
  42 (defmacro load-symbol (reg symbol)
  43   (once-only ((reg reg) (symbol symbol))
  44     `(let ((offset (static-symbol-offset ,symbol)))
  45        (cond
  46          ((typep offset '(signed-byte 11))
  47            (inst addi offset null-tn ,reg))
  48          (t
  49            (inst ldil offset ,reg)
  50            (inst ldo offset null-tn ,reg :unsigned t))))))
  51
  52 (defmacro load-symbol-value (reg symbol)
  53   `(inst ldw
  54          (+ (static-symbol-offset ',symbol)
  55             (ash symbol-value-slot word-shift)
  56             (- other-pointer-lowtag))
  57          null-tn ,reg))
  58
  59 (defmacro store-symbol-value (reg symbol)
  60   `(inst stw ,reg (+ (static-symbol-offset ',symbol)
  61                      (ash symbol-value-slot word-shift)
  62                      (- other-pointer-lowtag))
  63          null-tn))
  64
  65 (defmacro load-type (target source &optional (offset 0))
  66   #!+sb-doc
  67   "Loads the type bits of a pointer into target independent of
  68 byte-ordering issues."
  69   (once-only ((n-target target)
  70               (n-source source)
  71               (n-offset offset))
  72     (ecase *backend-byte-order*
  73       (:little-endian
  74        `(inst ldb ,n-offset ,n-source ,n-target))
  75       (:big-endian
  76        `(inst ldb (+ ,n-offset (1- n-word-bytes)) ,n-source ,n-target)))))
  77
  78 (defmacro set-lowtag (tag src dst)
  79   `(progn
  80      (inst move ,src ,dst)
  81      (inst dep ,tag 31 n-lowtag-bits ,dst)))
  82
  83 ;;; Macros to handle the fact that we cannot use the machine native call and
  84 ;;; return instructions.
  85
  86 (defmacro lisp-jump (function)
  87   #!+sb-doc
  88   "Jump to the lisp function FUNCTION."
  89   `(progn
  90      (inst addi (- (ash simple-fun-code-offset word-shift)
  91                    fun-pointer-lowtag) ,function lip-tn)
  92      (inst bv lip-tn)
  93      (move ,function code-tn t)))
  94
  95 (defmacro lisp-return (return-pc &key (offset 0) (frob-code t))
  96   #!+sb-doc
  97   "Return to RETURN-PC."
  98   `(progn
  99      (inst addi (- (* (1+ ,offset) n-word-bytes) other-pointer-lowtag)
 100            ,return-pc lip-tn)
 101      (inst bv lip-tn ,@(unless frob-code '(:nullify t)))
 102      ,@(if frob-code
 103          `((move ,return-pc code-tn t)))))
 104
 105 (defmacro emit-return-pc (label)
 106   #!+sb-doc
 107   "Emit a return-pc header word.  LABEL is the label to use for this
 108    return-pc."
 109   `(progn
 110      ;; alignment causes the return point to land on two address,
 111      ;; where the first must be nop pad.
 112      (emit-alignment n-lowtag-bits)
 113      (emit-label ,label)
 114      (inst lra-header-word)))
 115
 116 \f
 117 ;;;; Stack TN's
 118
 119 ;;; Move a stack TN to a register and vice-versa.
 120 (defmacro load-stack-tn (reg stack)
 121   `(let ((reg ,reg)
 122          (stack ,stack))
 123      (let ((offset (tn-offset stack)))
 124        (sc-case stack
 125          ((control-stack)
 126           (loadw reg cfp-tn offset))))))
 127
 128 (defmacro store-stack-tn (stack reg)
 129   `(let ((stack ,stack)
 130          (reg ,reg))
 131      (let ((offset (tn-offset stack)))
 132        (sc-case stack
 133          ((control-stack)
 134           (storew reg cfp-tn offset))))))
 135
 136 (defmacro maybe-load-stack-tn (reg reg-or-stack)
 137   #!+sb-doc
 138   "Move the TN Reg-Or-Stack into Reg if it isn't already there."
 139   (once-only ((n-reg reg)
 140               (n-stack reg-or-stack))
 141     `(sc-case ,n-reg
 142        ((any-reg descriptor-reg)
 143         (sc-case ,n-stack
 144           ((any-reg descriptor-reg)
 145            (move ,n-stack ,n-reg))
 146           ((control-stack)
 147            (loadw ,n-reg cfp-tn (tn-offset ,n-stack))))))))
 148
 149 \f
 150 ;;;; Storage allocation:
 151
 152 (defmacro with-fixed-allocation ((result-tn flag-tn temp-tn type-code
 153                                   size dynamic-extent-p
 154                                   &key (lowtag other-pointer-lowtag)
 155                                        maybe-write)
 156                                  &body body)
 157   #!+sb-doc
 158   "Do stuff to allocate an other-pointer object of fixed Size with a single
 159 word header having the specified Type-Code.  The result is placed in
 160 Result-TN, and Temp-TN is a non-descriptor temp (which may be randomly used
 161 by the body.)  The body is placed inside the PSEUDO-ATOMIC, and presumably
 162 initializes the object."
 163   (declare (ignore flag-tn))
 164   (once-only ((result-tn result-tn) (temp-tn temp-tn)
 165               (type-code type-code) (size size)
 166               (lowtag lowtag))
 167     (let ((write-body `((inst li (logior (ash (1- ,size) n-widetag-bits) ,type-code) ,temp-tn)
 168                         (storew ,temp-tn ,result-tn 0 ,lowtag))))
 169       `(if ,dynamic-extent-p
 170          (pseudo-atomic ()
 171            (align-csp ,temp-tn)
 172            (set-lowtag ,lowtag csp-tn ,result-tn)
 173            (inst addi (pad-data-block ,size) csp-tn csp-tn)
 174            ,@(if maybe-write
 175                `((when ,type-code ,@write-body))
 176                write-body)
 177            ,@body)
 178          (pseudo-atomic (:extra (pad-data-block ,size))
 179            (set-lowtag ,lowtag alloc-tn ,result-tn)
 180            ,@(if maybe-write
 181                `((when ,type-code ,@write-body))
 182                write-body)
 183            ,@body)))))
 184
 185 ;;; is used for stack allocation of dynamic-extent objects
 186 ;;; FIXME-lav, if using defun, atleast surround in assembly-form ? macro better ?
 187 (defun align-csp (temp)
 188   (declare (ignore temp))
 189   (let ((aligned (gen-label)))
 190     (inst extru csp-tn 31 n-lowtag-bits zero-tn :<>)
 191     (inst b aligned :nullify t)
 192     (inst addi n-word-bytes csp-tn csp-tn)
 193     (storew zero-tn csp-tn -1)
 194     (emit-label aligned)))
 195
 196 \f
 197 ;;;; Error Code
 198 (eval-when (#-sb-xc :compile-toplevel :load-toplevel :execute)
 199   (defun emit-error-break (vop kind code values)
 200     (let ((vector (gensym)))
 201       `((let ((vop ,vop))
 202           (when vop
 203             (note-this-location vop :internal-error)))
 204         (inst break ,kind)
 205         (with-adjustable-vector (,vector)
 206           (write-var-integer (error-number-or-lose ',code) ,vector)
 207           ,@(mapcar #'(lambda (tn)
 208                         `(let ((tn ,tn))
 209                            (write-var-integer (make-sc-offset (sc-number
 210                                                                (tn-sc tn))
 211                                                               (tn-offset tn))
 212                                               ,vector)))
 213                     values)
 214           (inst byte (length ,vector))
 215           (dotimes (i (length ,vector))
 216             (inst byte (aref ,vector i))))
 217         (emit-alignment word-shift)))))
 218
 219 (defmacro error-call (vop error-code &rest values)
 220   #!+sb-doc
 221   "Cause an error.  ERROR-CODE is the error to cause."
 222   (cons 'progn
 223         (emit-error-break vop error-trap error-code values)))
 224
 225
 226 (defmacro cerror-call (vop label error-code &rest values)
 227   #!+sb-doc
 228   "Cause a continuable error.  If the error is continued, execution resumes at
 229   LABEL."
 230   `(progn
 231      (without-scheduling ()
 232        (inst b ,label)
 233        ,@(emit-error-break vop cerror-trap error-code values))))
 234
 235 (defmacro generate-error-code (vop error-code &rest values)
 236   #!+sb-doc
 237   "Generate-Error-Code Error-code Value*
 238   Emit code for an error with the specified Error-Code and context Values."
 239   `(assemble (*elsewhere*)
 240      (let ((start-lab (gen-label)))
 241        (emit-label start-lab)
 242        (error-call ,vop ,error-code ,@values)
 243        start-lab)))
 244
 245 (defmacro generate-cerror-code (vop error-code &rest values)
 246   #!+sb-doc
 247   "Generate-CError-Code Error-code Value*
 248   Emit code for a continuable error with the specified Error-Code and
 249   context Values.  If the error is continued, execution resumes after
 250   the GENERATE-CERROR-CODE form."
 251   (with-unique-names (continue error)
 252     `(let ((,continue (gen-label)))
 253        (emit-label ,continue)
 254        (assemble (*elsewhere*)
 255          (let ((,error (gen-label)))
 256            (emit-label ,error)
 257            (cerror-call ,vop ,continue ,error-code ,@values)
 258            ,error)))))
 259 \f
 260 ;;;; PSEUDO-ATOMIC
 261
 262 ;;; handy macro for making sequences look atomic
 263 (defmacro pseudo-atomic ((&key (extra 0)) &rest forms)
 264   (let ((n-extra (gensym)))
 265     `(let ((,n-extra ,extra))
 266        (inst addi 4 alloc-tn alloc-tn)
 267        ,@forms
 268        (inst addit (- ,n-extra 4) alloc-tn alloc-tn :od))))
 269 \f
 270 ;;;; indexed references
 271
 272 (deftype load/store-index (scale lowtag min-offset
 273                                  &optional (max-offset min-offset))
 274   `(integer ,(- (truncate (+ (ash 1 14)
 275                              (* min-offset n-word-bytes)
 276                              (- lowtag))
 277                           scale))
 278             ,(truncate (- (+ (1- (ash 1 14)) lowtag)
 279                           (* max-offset n-word-bytes))
 280                        scale)))
 281
 282 (defmacro define-full-reffer (name type offset lowtag scs el-type
 283                                    &optional translate)
 284   `(progn
 285      (define-vop (,name)
 286        ,@(when translate
 287            `((:translate ,translate)))
 288        (:policy :fast-safe)
 289        (:args (object :scs (descriptor-reg))
 290               (index :scs (any-reg)))
 291        (:arg-types ,type tagged-num)
 292        (:temporary (:scs (interior-reg)) lip)
 293        (:results (value :scs ,scs))
 294        (:result-types ,el-type)
 295        (:generator 5
 296          (inst add object index lip)
 297          (loadw value lip ,offset ,lowtag)))
 298      (define-vop (,(symbolicate name "-C"))
 299        ,@(when translate
 300            `((:translate ,translate)))
 301        (:policy :fast-safe)
 302        (:args (object :scs (descriptor-reg)))
 303        (:info index)
 304        (:arg-types ,type
 305                    (:constant (load/store-index ,n-word-bytes ,(eval lowtag)
 306                                                 ,(eval offset))))
 307        (:results (value :scs ,scs))
 308        (:result-types ,el-type)
 309        (:generator 4
 310          (loadw value object (+ ,offset index) ,lowtag)))))
 311
 312 (defmacro define-full-setter (name type offset lowtag scs el-type
 313                                    &optional translate)
 314   `(progn
 315      (define-vop (,name)
 316        ,@(when translate
 317            `((:translate ,translate)))
 318        (:policy :fast-safe)
 319        (:args (object :scs (descriptor-reg))
 320               (index :scs (any-reg))
 321               (value :scs ,scs :target result))
 322        (:arg-types ,type tagged-num ,el-type)
 323        (:temporary (:scs (interior-reg)) lip)
 324        (:results (result :scs ,scs))
 325        (:result-types ,el-type)
 326        (:generator 2
 327          (inst add object index lip)
 328          (storew value lip ,offset ,lowtag)
 329          (move value result)))
 330      (define-vop (,(symbolicate name "-C"))
 331        ,@(when translate
 332            `((:translate ,translate)))
 333        (:policy :fast-safe)
 334        (:args (object :scs (descriptor-reg))
 335               (value :scs ,scs))
 336        (:info index)
 337        (:arg-types ,type
 338                    (:constant (load/store-index ,n-word-bytes ,(eval lowtag)
 339                                                 ,(eval offset)))
 340                    ,el-type)
 341        (:results (result :scs ,scs))
 342        (:result-types ,el-type)
 343        (:generator 1
 344          (storew value object (+ ,offset index) ,lowtag)
 345          (move value result)))))
 346
 347
 348 (defmacro define-partial-reffer (name type size signed offset lowtag scs
 349                                       el-type &optional translate)
 350   (let ((scale (ecase size (:byte 1) (:short 2))))
 351     `(progn
 352        (define-vop (,name)
 353          ,@(when translate
 354              `((:translate ,translate)))
 355          (:policy :fast-safe)
 356          (:args (object :scs (descriptor-reg) :to (:eval 0))
 357                 (index :scs (unsigned-reg)))
 358          (:arg-types ,type positive-fixnum)
 359          (:results (value :scs ,scs))
 360          (:result-types ,el-type)
 361          (:temporary (:scs (interior-reg)) lip)
 362          (:generator 5
 363            (inst ,(ecase size (:byte 'add) (:short 'sh1add))
 364                  index object lip)
 365            (inst ,(ecase size (:byte 'ldb) (:short 'ldh))
 366                  (- (* ,offset n-word-bytes) ,lowtag) lip value)
 367            ,@(when signed
 368                `((inst extrs value 31 ,(* scale n-byte-bits) value)))))
 369        (define-vop (,(symbolicate name "-C"))
 370          ,@(when translate
 371              `((:translate ,translate)))
 372          (:policy :fast-safe)
 373          (:args (object :scs (descriptor-reg)))
 374          (:info index)
 375          (:arg-types ,type
 376                      (:constant (load/store-index ,scale
 377                                                   ,(eval lowtag)
 378                                                   ,(eval offset))))
 379          (:results (value :scs ,scs))
 380          (:result-types ,el-type)
 381          (:generator 5
 382            (inst ,(ecase size (:byte 'ldb) (:short 'ldh))
 383                  (- (+ (* ,offset n-word-bytes) (* index ,scale)) ,lowtag)
 384                  object value)
 385            ,@(when signed
 386                `((inst extrs value 31 ,(* scale n-byte-bits) value))))))))
 387
 388 (defmacro define-partial-setter (name type size offset lowtag scs el-type
 389                                       &optional translate)
 390   (let ((scale (ecase size (:byte 1) (:short 2))))
 391     `(progn
 392        (define-vop (,name)
 393          ,@(when translate
 394              `((:translate ,translate)))
 395          (:policy :fast-safe)
 396          (:args (object :scs (descriptor-reg))
 397                 (index :scs (unsigned-reg))
 398                 (value :scs ,scs :target result))
 399          (:arg-types ,type positive-fixnum ,el-type)
 400          (:temporary (:scs (interior-reg)) lip)
 401          (:results (result :scs ,scs))
 402          (:result-types ,el-type)
 403          (:generator 5
 404            (inst ,(ecase size (:byte 'add) (:short 'sh1add))
 405                  index object lip)
 406            (inst ,(ecase size (:byte 'stb) (:short 'sth))
 407                  value (- (* ,offset n-word-bytes) ,lowtag) lip)
 408            (move value result)))
 409        (define-vop (,(symbolicate name "-C"))
 410          ,@(when translate
 411              `((:translate ,translate)))
 412          (:policy :fast-safe)
 413          (:args (object :scs (descriptor-reg))
 414                 (value :scs ,scs :target result))
 415          (:info index)
 416          (:arg-types ,type
 417                      (:constant (load/store-index ,scale
 418                                                   ,(eval lowtag)
 419                                                   ,(eval offset)))
 420                      ,el-type)
 421          (:results (result :scs ,scs))
 422          (:result-types ,el-type)
 423          (:generator 5
 424            (inst ,(ecase size (:byte 'stb) (:short 'sth))
 425                  value
 426                  (- (+ (* ,offset n-word-bytes) (* index ,scale)) ,lowtag)
 427                  object)
 428            (move value result))))))
 429
 430
 431 (def!macro with-pinned-objects ((&rest objects) &body body)
 432   "Arrange with the garbage collector that the pages occupied by
 433 OBJECTS will not be moved in memory for the duration of BODY.
 434 Useful for e.g. foreign calls where another thread may trigger
 435 garbage collection.  This is currently implemented by disabling GC"
 436   (declare (ignore objects))            ;should we eval these for side-effect?
 437   `(without-gcing
 438     ,@body))
 439