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
 367
 368 (defmacro sb!sys::with-pinned-objects ((&rest objects) &body body)
 369   "Arrange with the garbage collector that the pages occupied by
 370 OBJECTS will not be moved in memory for the duration of BODY.
 371 Useful for e.g. foreign calls where another thread may trigger
 372 garbage collection.  This is currently implemented by disabling GC"
 373   (declare (ignore objects))            ;should we eval these for side-effect?
 374   `(without-gcing
 375     ,@body))