src/compiler/hppa/macros.lisp

   1 (in-package "SB!VM")
   2
   3 \f
   4 ;;; Instruction-like macros.
   5
   6 (defmacro move (src dst)
   7   "Move SRC into DST unless they are location=."
   8   (once-only ((src src) (dst dst))
   9     `(unless (location= ,src ,dst)
  10        (inst move ,src ,dst))))
  11
  12 (defmacro loadw (result base &optional (offset 0) (lowtag 0))
  13   (once-only ((result result) (base base))
  14     `(inst ldw (- (ash ,offset word-shift) ,lowtag) ,base ,result)))
  15
  16 (defmacro storew (value base &optional (offset 0) (lowtag 0))
  17   (once-only ((value value) (base base) (offset offset) (lowtag lowtag))
  18     `(inst stw ,value (- (ash ,offset word-shift) ,lowtag) ,base)))
  19
  20 (defmacro load-symbol (reg symbol)
  21   (once-only ((reg reg) (symbol symbol))
  22     `(inst addi (static-symbol-offset ,symbol) null-tn ,reg)))
  23
  24 (defmacro load-symbol-value (reg symbol)
  25   `(inst ldw
  26          (+ (static-symbol-offset ',symbol)
  27             (ash symbol-value-slot word-shift)
  28             (- other-pointer-lowtag))
  29          null-tn
  30          ,reg))
  31
  32 (defmacro store-symbol-value (reg symbol)
  33   `(inst stw ,reg (+ (static-symbol-offset ',symbol)
  34                      (ash symbol-value-slot word-shift)
  35                      (- other-pointer-lowtag))
  36          null-tn))
  37
  38 (defmacro load-type (target source &optional (offset 0))
  39   "Loads the type bits of a pointer into target independent of
  40    byte-ordering issues."
  41   (ecase *backend-byte-order*
  42     (:little-endian
  43      `(inst ldb ,offset ,source ,target))
  44     (:big-endian
  45      `(inst ldb (+ ,offset 3) ,source ,target))))
  46
  47 ;;; Macros to handle the fact that we cannot use the machine native call and
  48 ;;; return instructions.
  49
  50 (defmacro lisp-jump (function)
  51   "Jump to the lisp function FUNCTION.  LIP is an interior-reg temporary."
  52   `(progn
  53      (inst addi
  54            (- (ash simple-fun-code-offset word-shift) fun-pointer-lowtag)
  55            ,function
  56            lip-tn)
  57      (inst bv lip-tn)
  58      (move ,function code-tn)))
  59
  60 (defmacro lisp-return (return-pc &key (offset 0) (frob-code t))
  61   "Return to RETURN-PC."
  62   `(progn
  63      (inst addi (- (* (1+ ,offset) n-word-bytes) other-pointer-lowtag)
  64            ,return-pc lip-tn)
  65      (inst bv lip-tn ,@(unless frob-code '(:nullify t)))
  66      ,@(when frob-code
  67          `((move ,return-pc code-tn)))))
  68
  69 (defmacro emit-return-pc (label)
  70   "Emit a return-pc header word.  LABEL is the label to use for this
  71    return-pc."
  72   `(progn
  73      (align n-lowtag-bits)
  74      (emit-label ,label)
  75      (inst lra-header-word)))
  76
  77 \f
  78 ;;;; Stack TN's
  79
  80 ;;; Load-Stack-TN, Store-Stack-TN  --  Interface
  81 ;;;
  82 ;;;    Move a stack TN to a register and vice-versa.
  83 ;;;
  84 (defmacro load-stack-tn (reg stack)
  85   `(let ((reg ,reg)
  86          (stack ,stack))
  87      (let ((offset (tn-offset stack)))
  88        (sc-case stack
  89          ((control-stack)
  90           (loadw reg cfp-tn offset))))))
  91
  92 (defmacro store-stack-tn (stack reg)
  93   `(let ((stack ,stack)
  94          (reg ,reg))
  95      (let ((offset (tn-offset stack)))
  96        (sc-case stack
  97          ((control-stack)
  98           (storew reg cfp-tn offset))))))
  99
 100
 101 ;;; MAYBE-LOAD-STACK-TN  --  Interface
 102 ;;;
 103 (defmacro maybe-load-stack-tn (reg reg-or-stack)
 104   "Move the TN Reg-Or-Stack into Reg if it isn't already there."
 105   (once-only ((n-reg reg)
 106               (n-stack reg-or-stack))
 107     `(sc-case ,n-reg
 108        ((any-reg descriptor-reg)
 109         (sc-case ,n-stack
 110           ((any-reg descriptor-reg)
 111            (move ,n-stack ,n-reg))
 112           ((control-stack)
 113            (loadw ,n-reg cfp-tn (tn-offset ,n-stack))))))))
 114
 115 \f
 116 ;;;; Storage allocation:
 117
 118 (defmacro with-fixed-allocation ((result-tn temp-tn type-code size)
 119                                  &body body)
 120   "Do stuff to allocate an other-pointer object of fixed Size with a single
 121   word header having the specified Type-Code.  The result is placed in
 122   Result-TN, and Temp-TN is a non-descriptor temp (which may be randomly used
 123   by the body.)  The body is placed inside the PSEUDO-ATOMIC, and presumably
 124   initializes the object."
 125   (once-only ((result-tn result-tn) (temp-tn temp-tn)
 126               (type-code type-code) (size size))
 127     `(pseudo-atomic (:extra (pad-data-block ,size))
 128        (inst move alloc-tn ,result-tn)
 129        (inst dep other-pointer-lowtag 31 3 ,result-tn)
 130        (inst li (logior (ash (1- ,size) n-widetag-bits) ,type-code) ,temp-tn)
 131        (storew ,temp-tn ,result-tn 0 other-pointer-lowtag)
 132        ,@body)))
 133
 134 \f
 135 ;;;; Error Code
 136
 137 (defvar *adjustable-vectors* nil)
 138
 139 (defmacro with-adjustable-vector ((var) &rest body)
 140   `(let ((,var (or (pop *adjustable-vectors*)
 141                    (make-array 16
 142                                :element-type '(unsigned-byte 8)
 143                                :fill-pointer 0
 144                                :adjustable t))))
 145      (declare (type (vector (unsigned-byte 8) 16) ,var))
 146      (setf (fill-pointer ,var) 0)
 147      (unwind-protect
 148          (progn
 149            ,@body)
 150        (push ,var *adjustable-vectors*))))
 151
 152 (eval-when (compile load eval)
 153   (defun emit-error-break (vop kind code values)
 154     (let ((vector (gensym)))
 155       `((let ((vop ,vop))
 156           (when vop
 157             (note-this-location vop :internal-error)))
 158         (inst break ,kind)
 159         (with-adjustable-vector (,vector)
 160           (write-var-integer (error-number-or-lose ',code) ,vector)
 161           ,@(mapcar #'(lambda (tn)
 162                         `(let ((tn ,tn))
 163                            (write-var-integer (make-sc-offset (sc-number
 164                                                                (tn-sc tn))
 165                                                               (tn-offset tn))
 166                                               ,vector)))
 167                     values)
 168           (inst byte (length ,vector))
 169           (dotimes (i (length ,vector))
 170             (inst byte (aref ,vector i))))
 171         (align word-shift)))))
 172
 173 (defmacro error-call (vop error-code &rest values)
 174   "Cause an error.  ERROR-CODE is the error to cause."
 175   (cons 'progn
 176         (emit-error-break vop error-trap error-code values)))
 177
 178
 179 (defmacro cerror-call (vop label error-code &rest values)
 180   "Cause a continuable error.  If the error is continued, execution resumes at
 181   LABEL."
 182   `(progn
 183      (inst b ,label)
 184      ,@(emit-error-break vop cerror-trap error-code values)))
 185
 186 (defmacro generate-error-code (vop error-code &rest values)
 187   "Generate-Error-Code Error-code Value*
 188   Emit code for an error with the specified Error-Code and context Values."
 189   `(assemble (*elsewhere*)
 190      (let ((start-lab (gen-label)))
 191        (emit-label start-lab)
 192        (error-call ,vop ,error-code ,@values)
 193        start-lab)))
 194
 195 (defmacro generate-cerror-code (vop error-code &rest values)
 196   "Generate-CError-Code Error-code Value*
 197   Emit code for a continuable error with the specified Error-Code and
 198   context Values.  If the error is continued, execution resumes after
 199   the GENERATE-CERROR-CODE form."
 200   (let ((continue (gensym "CONTINUE-LABEL-"))
 201         (error (gensym "ERROR-LABEL-")))
 202     `(let ((,continue (gen-label)))
 203        (emit-label ,continue)
 204        (assemble (*elsewhere*)
 205          (let ((,error (gen-label)))
 206            (emit-label ,error)
 207            (cerror-call ,vop ,continue ,error-code ,@values)
 208            ,error)))))
 209
 210
 211 \f
 212 ;;; PSEUDO-ATOMIC -- Handy macro for making sequences look atomic.
 213 ;;;
 214 (defmacro pseudo-atomic ((&key (extra 0)) &rest forms)
 215   (let ((n-extra (gensym)))
 216     `(let ((,n-extra ,extra))
 217        (inst addi 4 alloc-tn alloc-tn)
 218        ,@forms
 219        (inst addit (- ,n-extra 4) alloc-tn alloc-tn :od))))
 220
 221
 222 \f
 223 ;;;; Indexed references:
 224
 225 (deftype load/store-index (scale lowtag min-offset
 226                                  &optional (max-offset min-offset))
 227   `(integer ,(- (truncate (+ (ash 1 14)
 228                              (* min-offset n-word-bytes)
 229                              (- lowtag))
 230                           scale))
 231             ,(truncate (- (+ (1- (ash 1 14)) lowtag)
 232                           (* max-offset n-word-bytes))
 233                        scale)))
 234
 235 (defmacro define-full-reffer (name type offset lowtag scs el-type
 236                                    &optional translate)
 237   `(progn
 238      (define-vop (,name)
 239        ,@(when translate
 240            `((:translate ,translate)))
 241        (:policy :fast-safe)
 242        (:args (object :scs (descriptor-reg) :to (:eval 0))
 243               (index :scs (any-reg) :target temp))
 244        (:arg-types ,type tagged-num)
 245        (:temporary (:scs (non-descriptor-reg) :from (:argument 1)) temp)
 246        (:results (value :scs ,scs))
 247        (:result-types ,el-type)
 248        (:generator 5
 249          (inst addi (- (* ,offset n-word-bytes) ,lowtag) index temp)
 250          (inst ldwx temp object value)))
 251      (define-vop (,(symbolicate name "-C"))
 252        ,@(when translate
 253            `((:translate ,translate)))
 254        (:policy :fast-safe)
 255        (:args (object :scs (descriptor-reg)))
 256        (:info index)
 257        (:arg-types ,type
 258                    (:constant (load/store-index ,n-word-bytes ,(eval lowtag)
 259                                                 ,(eval offset))))
 260        (:results (value :scs ,scs))
 261        (:result-types ,el-type)
 262        (:generator 4
 263          (inst ldw (- (* (+ ,offset index) n-word-bytes) ,lowtag)
 264                object value)))))
 265
 266 (defmacro define-full-setter (name type offset lowtag scs el-type
 267                                    &optional translate)
 268   `(progn
 269      (define-vop (,name)
 270        ,@(when translate
 271            `((:translate ,translate)))
 272        (:policy :fast-safe)
 273        (:args (object :scs (descriptor-reg))
 274               (index :scs (any-reg))
 275               (value :scs ,scs :target result))
 276        (:arg-types ,type tagged-num ,el-type)
 277        (:temporary (:scs (interior-reg)) lip)
 278        (:results (result :scs ,scs))
 279        (:result-types ,el-type)
 280        (:generator 2
 281          (inst add object index lip)
 282          (inst stw value (- (* ,offset n-word-bytes) ,lowtag) lip)
 283          (move value result)))
 284      (define-vop (,(symbolicate name "-C"))
 285        ,@(when translate
 286            `((:translate ,translate)))
 287        (:policy :fast-safe)
 288        (:args (object :scs (descriptor-reg))
 289               (value :scs ,scs))
 290        (:info index)
 291        (:arg-types ,type
 292                    (:constant (load/store-index ,n-word-bytes ,(eval lowtag)
 293                                                 ,(eval offset)))
 294                    ,el-type)
 295        (:results (result :scs ,scs))
 296        (:result-types ,el-type)
 297        (:generator 1
 298          (inst stw value (- (* (+ ,offset index) n-word-bytes) ,lowtag) object)
 299          (move value result)))))
 300
 301
 302 (defmacro define-partial-reffer (name type size signed offset lowtag scs
 303                                       el-type &optional translate)
 304   (let ((scale (ecase size (:byte 1) (:short 2))))
 305     `(progn
 306        (define-vop (,name)
 307          ,@(when translate
 308              `((:translate ,translate)))
 309          (:policy :fast-safe)
 310          (:args (object :scs (descriptor-reg) :to (:eval 0))
 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            (inst ,(ecase size (:byte 'add) (:short 'sh1add))
 318                  index object lip)
 319            (inst ,(ecase size (:byte 'ldb) (:short 'ldh))
 320                  (- (* ,offset n-word-bytes) ,lowtag) lip value)
 321            ,@(when signed
 322                `((inst extrs value 31 ,(* scale n-byte-bits) value)))))
 323        (define-vop (,(symbolicate name "-C"))
 324          ,@(when translate
 325              `((:translate ,translate)))
 326          (:policy :fast-safe)
 327          (:args (object :scs (descriptor-reg)))
 328          (:info index)
 329          (:arg-types ,type
 330                      (:constant (load/store-index ,scale
 331                                                   ,(eval lowtag)
 332                                                   ,(eval offset))))
 333          (:results (value :scs ,scs))
 334          (:result-types ,el-type)
 335          (:generator 5
 336            (inst ,(ecase size (:byte 'ldb) (:short 'ldh))
 337                  (- (+ (* ,offset n-word-bytes) (* index ,scale)) ,lowtag)
 338                  object value)
 339            ,@(when signed
 340                `((inst extrs value 31 ,(* scale n-byte-bits) value))))))))
 341
 342 (defmacro define-partial-setter (name type size offset lowtag scs el-type
 343                                       &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))
 351                 (index :scs (unsigned-reg))
 352                 (value :scs ,scs :target result))
 353          (:arg-types ,type positive-fixnum ,el-type)
 354          (:temporary (:scs (interior-reg)) lip)
 355          (:results (result :scs ,scs))
 356          (:result-types ,el-type)
 357          (:generator 5
 358            (inst ,(ecase size (:byte 'add) (:short 'sh1add))
 359                  index object lip)
 360            (inst ,(ecase size (:byte 'stb) (:short 'sth))
 361                  value (- (* ,offset n-word-bytes) ,lowtag) lip)
 362            (move value result)))
 363        (define-vop (,(symbolicate name "-C"))
 364          ,@(when translate
 365              `((:translate ,translate)))
 366          (:policy :fast-safe)
 367          (:args (object :scs (descriptor-reg))
 368                 (value :scs ,scs :target result))
 369          (:info index)
 370          (:arg-types ,type
 371                      (:constant (load/store-index ,scale
 372                                                   ,(eval lowtag)
 373                                                   ,(eval offset)))
 374                      ,el-type)
 375          (:results (result :scs ,scs))
 376          (:result-types ,el-type)
 377          (:generator 5
 378            (inst ,(ecase size (:byte 'stb) (:short 'sth))
 379                  value
 380                  (- (+ (* ,offset n-word-bytes) (* index ,scale)) ,lowtag)
 381                  object)
 382            (move value result))))))
 383