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