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 (1- n-word-bytes)) ,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   (unless body
 129     (bug "empty &body in WITH-FIXED-ALLOCATION"))
 130   (once-only ((result-tn result-tn) (temp-tn temp-tn)
 131               (type-code type-code) (size size))
 132     `(pseudo-atomic (:extra (pad-data-block ,size))
 133        (inst move alloc-tn ,result-tn)
 134        (inst dep other-pointer-lowtag 31 3 ,result-tn)
 135        (inst li (logior (ash (1- ,size) n-widetag-bits) ,type-code) ,temp-tn)
 136        (storew ,temp-tn ,result-tn 0 other-pointer-lowtag)
 137        ,@body)))
 138
 139 \f
 140 ;;;; Error Code
 141 (eval-when (compile load eval)
 142   (defun emit-error-break (vop kind code values)
 143     (let ((vector (gensym)))
 144       `((let ((vop ,vop))
 145           (when vop
 146             (note-this-location vop :internal-error)))
 147         (inst break ,kind)
 148         (with-adjustable-vector (,vector)
 149           (write-var-integer (error-number-or-lose ',code) ,vector)
 150           ,@(mapcar #'(lambda (tn)
 151                         `(let ((tn ,tn))
 152                            (write-var-integer (make-sc-offset (sc-number
 153                                                                (tn-sc tn))
 154                                                               (tn-offset tn))
 155                                               ,vector)))
 156                     values)
 157           (inst byte (length ,vector))
 158           (dotimes (i (length ,vector))
 159             (inst byte (aref ,vector i))))
 160         (align word-shift)))))
 161
 162 (defmacro error-call (vop error-code &rest values)
 163   "Cause an error.  ERROR-CODE is the error to cause."
 164   (cons 'progn
 165         (emit-error-break vop error-trap error-code values)))
 166
 167
 168 (defmacro cerror-call (vop label error-code &rest values)
 169   "Cause a continuable error.  If the error is continued, execution resumes at
 170   LABEL."
 171   `(progn
 172      (inst b ,label)
 173      ,@(emit-error-break vop cerror-trap error-code values)))
 174
 175 (defmacro generate-error-code (vop error-code &rest values)
 176   "Generate-Error-Code Error-code Value*
 177   Emit code for an error with the specified Error-Code and context Values."
 178   `(assemble (*elsewhere*)
 179      (let ((start-lab (gen-label)))
 180        (emit-label start-lab)
 181        (error-call ,vop ,error-code ,@values)
 182        start-lab)))
 183
 184 (defmacro generate-cerror-code (vop error-code &rest values)
 185   "Generate-CError-Code Error-code Value*
 186   Emit code for a continuable error with the specified Error-Code and
 187   context Values.  If the error is continued, execution resumes after
 188   the GENERATE-CERROR-CODE form."
 189   (with-unique-names (continue error)
 190     `(let ((,continue (gen-label)))
 191        (emit-label ,continue)
 192        (assemble (*elsewhere*)
 193          (let ((,error (gen-label)))
 194            (emit-label ,error)
 195            (cerror-call ,vop ,continue ,error-code ,@values)
 196            ,error)))))
 197 \f
 198 ;;;; PSEUDO-ATOMIC
 199
 200 ;;; handy macro for making sequences look atomic
 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 \f
 208 ;;;; indexed references
 209
 210 (deftype load/store-index (scale lowtag min-offset
 211                                  &optional (max-offset min-offset))
 212   `(integer ,(- (truncate (+ (ash 1 14)
 213                              (* min-offset n-word-bytes)
 214                              (- lowtag))
 215                           scale))
 216             ,(truncate (- (+ (1- (ash 1 14)) lowtag)
 217                           (* max-offset n-word-bytes))
 218                        scale)))
 219
 220 (defmacro define-full-reffer (name type offset lowtag scs el-type
 221                                    &optional translate)
 222   `(progn
 223      (define-vop (,name)
 224        ,@(when translate
 225            `((:translate ,translate)))
 226        (:policy :fast-safe)
 227        (:args (object :scs (descriptor-reg) :to (:eval 0))
 228               (index :scs (any-reg) :target temp))
 229        (:arg-types ,type tagged-num)
 230        (:temporary (:scs (non-descriptor-reg) :from (:argument 1)) temp)
 231        (:results (value :scs ,scs))
 232        (:result-types ,el-type)
 233        (:generator 5
 234          (inst addi (- (* ,offset n-word-bytes) ,lowtag) index temp)
 235          (inst ldwx temp object value)))
 236      (define-vop (,(symbolicate name "-C"))
 237        ,@(when translate
 238            `((:translate ,translate)))
 239        (:policy :fast-safe)
 240        (:args (object :scs (descriptor-reg)))
 241        (:info index)
 242        (:arg-types ,type
 243                    (:constant (load/store-index ,n-word-bytes ,(eval lowtag)
 244                                                 ,(eval offset))))
 245        (:results (value :scs ,scs))
 246        (:result-types ,el-type)
 247        (:generator 4
 248          (inst ldw (- (* (+ ,offset index) n-word-bytes) ,lowtag)
 249                object value)))))
 250
 251 (defmacro define-full-setter (name type offset lowtag scs el-type
 252                                    &optional translate)
 253   `(progn
 254      (define-vop (,name)
 255        ,@(when translate
 256            `((:translate ,translate)))
 257        (:policy :fast-safe)
 258        (:args (object :scs (descriptor-reg))
 259               (index :scs (any-reg))
 260               (value :scs ,scs :target result))
 261        (:arg-types ,type tagged-num ,el-type)
 262        (:temporary (:scs (interior-reg)) lip)
 263        (:results (result :scs ,scs))
 264        (:result-types ,el-type)
 265        (:generator 2
 266          (inst add object index lip)
 267          (inst stw value (- (* ,offset n-word-bytes) ,lowtag) lip)
 268          (move value result)))
 269      (define-vop (,(symbolicate name "-C"))
 270        ,@(when translate
 271            `((:translate ,translate)))
 272        (:policy :fast-safe)
 273        (:args (object :scs (descriptor-reg))
 274               (value :scs ,scs))
 275        (:info index)
 276        (:arg-types ,type
 277                    (:constant (load/store-index ,n-word-bytes ,(eval lowtag)
 278                                                 ,(eval offset)))
 279                    ,el-type)
 280        (:results (result :scs ,scs))
 281        (:result-types ,el-type)
 282        (:generator 1
 283          (inst stw value (- (* (+ ,offset index) n-word-bytes) ,lowtag) object)
 284          (move value result)))))
 285
 286
 287 (defmacro define-partial-reffer (name type size signed offset lowtag scs
 288                                       el-type &optional translate)
 289   (let ((scale (ecase size (:byte 1) (:short 2))))
 290     `(progn
 291        (define-vop (,name)
 292          ,@(when translate
 293              `((:translate ,translate)))
 294          (:policy :fast-safe)
 295          (:args (object :scs (descriptor-reg) :to (:eval 0))
 296                 (index :scs (unsigned-reg)))
 297          (:arg-types ,type positive-fixnum)
 298          (:results (value :scs ,scs))
 299          (:result-types ,el-type)
 300          (:temporary (:scs (interior-reg)) lip)
 301          (:generator 5
 302            (inst ,(ecase size (:byte 'add) (:short 'sh1add))
 303                  index object lip)
 304            (inst ,(ecase size (:byte 'ldb) (:short 'ldh))
 305                  (- (* ,offset n-word-bytes) ,lowtag) lip value)
 306            ,@(when signed
 307                `((inst extrs value 31 ,(* scale n-byte-bits) value)))))
 308        (define-vop (,(symbolicate name "-C"))
 309          ,@(when translate
 310              `((:translate ,translate)))
 311          (:policy :fast-safe)
 312          (:args (object :scs (descriptor-reg)))
 313          (:info index)
 314          (:arg-types ,type
 315                      (:constant (load/store-index ,scale
 316                                                   ,(eval lowtag)
 317                                                   ,(eval offset))))
 318          (:results (value :scs ,scs))
 319          (:result-types ,el-type)
 320          (:generator 5
 321            (inst ,(ecase size (:byte 'ldb) (:short 'ldh))
 322                  (- (+ (* ,offset n-word-bytes) (* index ,scale)) ,lowtag)
 323                  object value)
 324            ,@(when signed
 325                `((inst extrs value 31 ,(* scale n-byte-bits) value))))))))
 326
 327 (defmacro define-partial-setter (name type size offset lowtag scs el-type
 328                                       &optional translate)
 329   (let ((scale (ecase size (:byte 1) (:short 2))))
 330     `(progn
 331        (define-vop (,name)
 332          ,@(when translate
 333              `((:translate ,translate)))
 334          (:policy :fast-safe)
 335          (:args (object :scs (descriptor-reg))
 336                 (index :scs (unsigned-reg))
 337                 (value :scs ,scs :target result))
 338          (:arg-types ,type positive-fixnum ,el-type)
 339          (:temporary (:scs (interior-reg)) lip)
 340          (:results (result :scs ,scs))
 341          (:result-types ,el-type)
 342          (:generator 5
 343            (inst ,(ecase size (:byte 'add) (:short 'sh1add))
 344                  index object lip)
 345            (inst ,(ecase size (:byte 'stb) (:short 'sth))
 346                  value (- (* ,offset n-word-bytes) ,lowtag) lip)
 347            (move value result)))
 348        (define-vop (,(symbolicate name "-C"))
 349          ,@(when translate
 350              `((:translate ,translate)))
 351          (:policy :fast-safe)
 352          (:args (object :scs (descriptor-reg))
 353                 (value :scs ,scs :target result))
 354          (:info index)
 355          (:arg-types ,type
 356                      (:constant (load/store-index ,scale
 357                                                   ,(eval lowtag)
 358                                                   ,(eval offset)))
 359                      ,el-type)
 360          (:results (result :scs ,scs))
 361          (:result-types ,el-type)
 362          (:generator 5
 363            (inst ,(ecase size (:byte 'stb) (:short 'sth))
 364                  value
 365                  (- (+ (* ,offset n-word-bytes) (* index ,scale)) ,lowtag)
 366                  object)
 367            (move value result))))))
 368
 369
 370 (def!macro with-pinned-objects ((&rest objects) &body body)
 371   "Arrange with the garbage collector that the pages occupied by
 372 OBJECTS will not be moved in memory for the duration of BODY.
 373 Useful for e.g. foreign calls where another thread may trigger
 374 garbage collection.  This is currently implemented by disabling GC"
 375   (declare (ignore objects))            ;should we eval these for side-effect?
 376   `(without-gcing
 377     ,@body))