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