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