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