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   (with-unique-names (continue error)
 188     `(let ((,continue (gen-label)))
 189        (emit-label ,continue)
 190        (assemble (*elsewhere*)
 191          (let ((,error (gen-label)))
 192            (emit-label ,error)
 193            (cerror-call ,vop ,continue ,error-code ,@values)
 194            ,error)))))
 195 \f
 196 ;;;; PSEUDO-ATOMIC
 197
 198 ;;; handy macro for making sequences look atomic
 199 (defmacro pseudo-atomic ((&key (extra 0)) &rest forms)
 200   (let ((n-extra (gensym)))
 201     `(let ((,n-extra ,extra))
 202        (inst addi 4 alloc-tn alloc-tn)
 203        ,@forms
 204        (inst addit (- ,n-extra 4) alloc-tn alloc-tn :od))))
 205 \f
 206 ;;;; indexed references
 207
 208 (deftype load/store-index (scale lowtag min-offset
 209                                  &optional (max-offset min-offset))
 210   `(integer ,(- (truncate (+ (ash 1 14)
 211                              (* min-offset n-word-bytes)
 212                              (- lowtag))
 213                           scale))
 214             ,(truncate (- (+ (1- (ash 1 14)) lowtag)
 215                           (* max-offset n-word-bytes))
 216                        scale)))
 217
 218 (defmacro define-full-reffer (name type offset lowtag scs el-type
 219                                    &optional translate)
 220   `(progn
 221      (define-vop (,name)
 222        ,@(when translate
 223            `((:translate ,translate)))
 224        (:policy :fast-safe)
 225        (:args (object :scs (descriptor-reg) :to (:eval 0))
 226               (index :scs (any-reg) :target temp))
 227        (:arg-types ,type tagged-num)
 228        (:temporary (:scs (non-descriptor-reg) :from (:argument 1)) temp)
 229        (:results (value :scs ,scs))
 230        (:result-types ,el-type)
 231        (:generator 5
 232          (inst addi (- (* ,offset n-word-bytes) ,lowtag) index temp)
 233          (inst ldwx temp object value)))
 234      (define-vop (,(symbolicate name "-C"))
 235        ,@(when translate
 236            `((:translate ,translate)))
 237        (:policy :fast-safe)
 238        (:args (object :scs (descriptor-reg)))
 239        (:info index)
 240        (:arg-types ,type
 241                    (:constant (load/store-index ,n-word-bytes ,(eval lowtag)
 242                                                 ,(eval offset))))
 243        (:results (value :scs ,scs))
 244        (:result-types ,el-type)
 245        (:generator 4
 246          (inst ldw (- (* (+ ,offset index) n-word-bytes) ,lowtag)
 247                object value)))))
 248
 249 (defmacro define-full-setter (name type offset lowtag scs el-type
 250                                    &optional translate)
 251   `(progn
 252      (define-vop (,name)
 253        ,@(when translate
 254            `((:translate ,translate)))
 255        (:policy :fast-safe)
 256        (:args (object :scs (descriptor-reg))
 257               (index :scs (any-reg))
 258               (value :scs ,scs :target result))
 259        (:arg-types ,type tagged-num ,el-type)
 260        (:temporary (:scs (interior-reg)) lip)
 261        (:results (result :scs ,scs))
 262        (:result-types ,el-type)
 263        (:generator 2
 264          (inst add object index lip)
 265          (inst stw value (- (* ,offset n-word-bytes) ,lowtag) lip)
 266          (move value result)))
 267      (define-vop (,(symbolicate name "-C"))
 268        ,@(when translate
 269            `((:translate ,translate)))
 270        (:policy :fast-safe)
 271        (:args (object :scs (descriptor-reg))
 272               (value :scs ,scs))
 273        (:info index)
 274        (:arg-types ,type
 275                    (:constant (load/store-index ,n-word-bytes ,(eval lowtag)
 276                                                 ,(eval offset)))
 277                    ,el-type)
 278        (:results (result :scs ,scs))
 279        (:result-types ,el-type)
 280        (:generator 1
 281          (inst stw value (- (* (+ ,offset index) n-word-bytes) ,lowtag) object)
 282          (move value result)))))
 283
 284
 285 (defmacro define-partial-reffer (name type size signed offset lowtag scs
 286                                       el-type &optional translate)
 287   (let ((scale (ecase size (:byte 1) (:short 2))))
 288     `(progn
 289        (define-vop (,name)
 290          ,@(when translate
 291              `((:translate ,translate)))
 292          (:policy :fast-safe)
 293          (:args (object :scs (descriptor-reg) :to (:eval 0))
 294                 (index :scs (unsigned-reg)))
 295          (:arg-types ,type positive-fixnum)
 296          (:results (value :scs ,scs))
 297          (:result-types ,el-type)
 298          (:temporary (:scs (interior-reg)) lip)
 299          (:generator 5
 300            (inst ,(ecase size (:byte 'add) (:short 'sh1add))
 301                  index object lip)
 302            (inst ,(ecase size (:byte 'ldb) (:short 'ldh))
 303                  (- (* ,offset n-word-bytes) ,lowtag) lip value)
 304            ,@(when signed
 305                `((inst extrs value 31 ,(* scale n-byte-bits) value)))))
 306        (define-vop (,(symbolicate name "-C"))
 307          ,@(when translate
 308              `((:translate ,translate)))
 309          (:policy :fast-safe)
 310          (:args (object :scs (descriptor-reg)))
 311          (:info index)
 312          (:arg-types ,type
 313                      (:constant (load/store-index ,scale
 314                                                   ,(eval lowtag)
 315                                                   ,(eval offset))))
 316          (:results (value :scs ,scs))
 317          (:result-types ,el-type)
 318          (:generator 5
 319            (inst ,(ecase size (:byte 'ldb) (:short 'ldh))
 320                  (- (+ (* ,offset n-word-bytes) (* index ,scale)) ,lowtag)
 321                  object value)
 322            ,@(when signed
 323                `((inst extrs value 31 ,(* scale n-byte-bits) value))))))))
 324
 325 (defmacro define-partial-setter (name type size offset lowtag scs el-type
 326                                       &optional translate)
 327   (let ((scale (ecase size (:byte 1) (:short 2))))
 328     `(progn
 329        (define-vop (,name)
 330          ,@(when translate
 331              `((:translate ,translate)))
 332          (:policy :fast-safe)
 333          (:args (object :scs (descriptor-reg))
 334                 (index :scs (unsigned-reg))
 335                 (value :scs ,scs :target result))
 336          (:arg-types ,type positive-fixnum ,el-type)
 337          (:temporary (:scs (interior-reg)) lip)
 338          (:results (result :scs ,scs))
 339          (:result-types ,el-type)
 340          (:generator 5
 341            (inst ,(ecase size (:byte 'add) (:short 'sh1add))
 342                  index object lip)
 343            (inst ,(ecase size (:byte 'stb) (:short 'sth))
 344                  value (- (* ,offset n-word-bytes) ,lowtag) lip)
 345            (move value result)))
 346        (define-vop (,(symbolicate name "-C"))
 347          ,@(when translate
 348              `((:translate ,translate)))
 349          (:policy :fast-safe)
 350          (:args (object :scs (descriptor-reg))
 351                 (value :scs ,scs :target result))
 352          (:info index)
 353          (:arg-types ,type
 354                      (:constant (load/store-index ,scale
 355                                                   ,(eval lowtag)
 356                                                   ,(eval offset)))
 357                      ,el-type)
 358          (:results (result :scs ,scs))
 359          (:result-types ,el-type)
 360          (:generator 5
 361            (inst ,(ecase size (:byte 'stb) (:short 'sth))
 362                  value
 363                  (- (+ (* ,offset n-word-bytes) (* index ,scale)) ,lowtag)
 364                  object)
 365            (move value result))))))
 366