src/compiler/alpha/macros.lisp

   1 ;;;; various useful macros for generating Alpha 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
  12 (in-package "SB!VM")
  13
  14 ;;; a handy macro for defining top level forms that depend on the
  15 ;;; compile environment
  16 (defmacro expand (expr)
  17   (let ((gensym (gensym)))
  18     `(macrolet
  19          ((,gensym ()
  20             ,expr))
  21        (,gensym))))
  22 \f
  23 ;;; instruction-like macros
  24
  25 ;;; c.f. x86 backend:
  26 ;;(defmacro move (dst src)
  27 ;;  #!+sb-doc
  28 ;;  "Move SRC into DST unless they are location=."
  29 ;;  (once-only ((n-dst dst)
  30 ;;              (n-src src))
  31 ;;    `(unless (location= ,n-dst ,n-src)
  32 ;;       (inst mov ,n-dst ,n-src))))
  33
  34 (defmacro move (src dst)
  35   "Move SRC into DST unless they are location=."
  36   (once-only ((n-src src) (n-dst dst))
  37     `(unless (location= ,n-src ,n-dst)
  38        (inst move ,n-src ,n-dst))))
  39
  40 (defmacro loadw (result base &optional (offset 0) (lowtag 0))
  41   (once-only ((result result) (base base))
  42     `(inst ldl ,result (- (ash ,offset word-shift) ,lowtag) ,base)))
  43
  44 (defmacro loadq (result base &optional (offset 0) (lowtag 0))
  45   (once-only ((result result) (base base))
  46     `(inst ldq ,result (- (ash ,offset word-shift) ,lowtag) ,base)))
  47
  48 (defmacro storew (value base &optional (offset 0) (lowtag 0))
  49   (once-only ((value value) (base base) (offset offset) (lowtag lowtag))
  50     `(inst stl ,value (- (ash ,offset word-shift) ,lowtag) ,base)))
  51
  52 (defmacro storeq (value base &optional (offset 0) (lowtag 0))
  53   (once-only ((value value) (base base) (offset offset) (lowtag lowtag))
  54     `(inst stq ,value (- (ash ,offset word-shift) ,lowtag) ,base)))
  55
  56 (defmacro load-symbol (reg symbol)
  57   (once-only ((reg reg) (symbol symbol))
  58     `(inst lda ,reg (static-symbol-offset ,symbol) null-tn)))
  59
  60 (defmacro load-symbol-value (reg symbol)
  61   `(inst ldl ,reg
  62          (+ (static-symbol-offset ',symbol)
  63             (ash symbol-value-slot word-shift)
  64             (- other-pointer-lowtag))
  65          null-tn))
  66
  67 (defmacro store-symbol-value (reg symbol)
  68   `(inst stl ,reg
  69          (+ (static-symbol-offset ',symbol)
  70             (ash symbol-value-slot word-shift)
  71             (- other-pointer-lowtag))
  72          null-tn))
  73
  74 (defmacro load-type (target source &optional (offset 0))
  75   "Loads the type bits of a pointer into target independent of
  76   byte-ordering issues."
  77   (once-only ((n-target target)
  78               (n-source source)
  79               (n-offset offset))
  80      `(progn
  81         (inst ldl ,n-target ,n-offset ,n-source)
  82         (inst and ,n-target #xff ,n-target))))
  83
  84 ;;; macros to handle the fact that we cannot use the machine native
  85 ;;; call and return instructions
  86
  87 (defmacro lisp-jump (function lip)
  88   "Jump to the lisp function FUNCTION.  LIP is an interior-reg temporary."
  89   `(progn
  90      (inst lda ,lip (- (ash simple-fun-code-offset word-shift)
  91                        fun-pointer-lowtag)
  92             ,function)
  93      (move ,function code-tn)
  94      (inst jsr zero-tn ,lip 1)))
  95
  96 (defmacro lisp-return (return-pc lip &key (offset 0) (frob-code t))
  97   "Return to RETURN-PC.  LIP is an interior-reg temporary."
  98   `(progn
  99      (inst lda ,lip
 100            (- (* (1+ ,offset) n-word-bytes) other-pointer-lowtag)
 101             ,return-pc)
 102      ,@(when frob-code
 103          `((move ,return-pc code-tn)))
 104      (inst ret zero-tn ,lip 1)))
 105
 106
 107 (defmacro emit-return-pc (label)
 108   "Emit a return-pc header word.  LABEL is the label to use for this
 109    return-pc."
 110   `(progn
 111      (align n-lowtag-bits)
 112      (emit-label ,label)
 113      (inst lra-header-word)))
 114
 115
 116 \f
 117 ;;;; stack TN's
 118
 119 ;;;    Move a stack TN to a register and vice-versa.
 120 (defmacro load-stack-tn (reg stack)
 121   `(let ((reg ,reg)
 122          (stack ,stack))
 123      (let ((offset (tn-offset stack)))
 124        (sc-case stack
 125          ((control-stack)
 126           (loadw reg cfp-tn offset))))))
 127 (defmacro store-stack-tn (stack reg)
 128   `(let ((stack ,stack)
 129          (reg ,reg))
 130      (let ((offset (tn-offset stack)))
 131        (sc-case stack
 132          ((control-stack)
 133           (storew reg cfp-tn offset))))))
 134
 135 ;;; Move the TN Reg-Or-Stack into Reg if it isn't already there.
 136 (defmacro maybe-load-stack-tn (reg reg-or-stack)
 137   (once-only ((n-reg reg)
 138               (n-stack reg-or-stack))
 139     `(sc-case ,n-reg
 140        ((any-reg descriptor-reg)
 141         (sc-case ,n-stack
 142           ((any-reg descriptor-reg)
 143            (move ,n-stack ,n-reg))
 144           ((control-stack)
 145            (loadw ,n-reg cfp-tn (tn-offset ,n-stack))))))))
 146
 147 ;;; Move the TN Reg-Or-Stack into Reg if it isn't already there.
 148 (defmacro maybe-load-stack-nfp-tn (reg reg-or-stack temp)
 149   (once-only ((n-reg reg)
 150               (n-stack reg-or-stack))
 151      `(when ,reg
 152         (sc-case ,n-reg
 153          ((any-reg descriptor-reg)
 154           (sc-case ,n-stack
 155            ((any-reg descriptor-reg)
 156             (move ,n-stack ,n-reg))
 157            ((control-stack)
 158             (loadw ,n-reg cfp-tn (tn-offset ,n-stack))
 159             (inst mskll nsp-tn 0 ,temp)
 160             (inst bis ,temp ,n-reg ,n-reg))))))))
 161 \f
 162 ;;;; storage allocation
 163
 164 ;;; Do stuff to allocate an other-pointer object of fixed SIZE with a
 165 ;;; single word header having the specified WIDETAG value. The result is
 166 ;;; placed in RESULT-TN, Flag-Tn must be wired to NL3-OFFSET, and
 167 ;;; Temp-TN is a non- descriptor temp (which may be randomly used by
 168 ;;; the body.) The body is placed inside the PSEUDO-ATOMIC, and
 169 ;;; presumably initializes the object.
 170 (defmacro with-fixed-allocation ((result-tn temp-tn widetag size)
 171                                  &body body)
 172   `(pseudo-atomic (:extra (pad-data-block ,size))
 173      (inst bis alloc-tn other-pointer-lowtag ,result-tn)
 174      (inst li (logior (ash (1- ,size) n-widetag-bits) ,widetag) ,temp-tn)
 175      (storew ,temp-tn ,result-tn 0 other-pointer-lowtag)
 176      ,@body))
 177 \f
 178 ;;;; error code
 179 (eval-when (:compile-toplevel :load-toplevel :execute)
 180   (defun emit-error-break (vop kind code values)
 181     (let ((vector (gensym)))
 182       `((let ((vop ,vop))
 183           (when vop
 184             (note-this-location vop :internal-error)))
 185         (inst gentrap ,kind)
 186         (with-adjustable-vector (,vector)
 187           (write-var-integer (error-number-or-lose ',code) ,vector)
 188           ,@(mapcar (lambda (tn)
 189                       `(let ((tn ,tn))
 190                          (write-var-integer (make-sc-offset (sc-number
 191                                                              (tn-sc tn))
 192                                                             (tn-offset tn))
 193                                             ,vector)))
 194                     values)
 195           (inst byte (length ,vector))
 196           (dotimes (i (length ,vector))
 197             (inst byte (aref ,vector i))))
 198         (align word-shift)))))
 199
 200 (defmacro error-call (vop error-code &rest values)
 201   "Cause an error.  ERROR-CODE is the error to cause."
 202   (cons 'progn
 203         (emit-error-break vop error-trap error-code values)))
 204
 205
 206 (defmacro cerror-call (vop label error-code &rest values)
 207   "Cause a continuable error.  If the error is continued, execution resumes at
 208   LABEL."
 209   `(progn
 210      (inst br zero-tn ,label)
 211      ,@(emit-error-break vop cerror-trap error-code values)))
 212
 213 (defmacro generate-error-code (vop error-code &rest values)
 214   "Generate-Error-Code Error-code Value*
 215   Emit code for an error with the specified Error-Code and context Values."
 216   `(assemble (*elsewhere*)
 217      (let ((start-lab (gen-label)))
 218        (emit-label start-lab)
 219        (error-call ,vop ,error-code ,@values)
 220        start-lab)))
 221
 222 (defmacro generate-cerror-code (vop error-code &rest values)
 223   "Generate-CError-Code Error-code Value*
 224   Emit code for a continuable error with the specified Error-Code and
 225   context Values.  If the error is continued, execution resumes after
 226   the GENERATE-CERROR-CODE form."
 227   (with-unique-names (continue error)
 228     `(let ((,continue (gen-label)))
 229        (emit-label ,continue)
 230        (assemble (*elsewhere*)
 231          (let ((,error (gen-label)))
 232            (emit-label ,error)
 233            (cerror-call ,vop ,continue ,error-code ,@values)
 234            ,error)))))
 235
 236 \f
 237 ;;; a handy macro for making sequences look atomic
 238 (defmacro pseudo-atomic ((&key (extra 0)) &rest forms)
 239   `(progn
 240      (inst addq alloc-tn 1 alloc-tn)
 241      ,@forms
 242      (inst lda alloc-tn (1- ,extra) alloc-tn)
 243      (inst stl zero-tn 0 alloc-tn)))
 244 \f
 245 ;;;; memory accessor vop generators
 246
 247 (defmacro define-full-reffer (name type offset lowtag scs el-type
 248                                    &optional translate)
 249   `(progn
 250      (define-vop (,name)
 251        ,@(when translate
 252            `((:translate ,translate)))
 253        (:policy :fast-safe)
 254        (:args (object :scs (descriptor-reg))
 255               (index :scs (any-reg)))
 256        (:arg-types ,type tagged-num)
 257        (:temporary (:scs (interior-reg)) lip)
 258        (:results (value :scs ,scs))
 259        (:result-types ,el-type)
 260        (:generator 5
 261          (inst addq object index lip)
 262          (inst ldl value (- (* ,offset n-word-bytes) ,lowtag) lip)
 263          ,@(when (equal scs '(unsigned-reg))
 264              '((inst mskll value 4 value)))))
 265      (define-vop (,(symbolicate name "-C"))
 266        ,@(when translate
 267            `((:translate ,translate)))
 268        (:policy :fast-safe)
 269        (:args (object :scs (descriptor-reg)))
 270        (:info index)
 271        (:arg-types ,type
 272                    (:constant (load/store-index ,n-word-bytes ,(eval lowtag)
 273                                                 ,(eval offset))))
 274        (:results (value :scs ,scs))
 275        (:result-types ,el-type)
 276        (:generator 4
 277          (inst ldl value (- (* (+ ,offset index) n-word-bytes) ,lowtag)
 278                object)
 279          ,@(when (equal scs '(unsigned-reg))
 280              '((inst mskll value 4 value)))))))
 281
 282 (defmacro define-full-setter (name type offset lowtag scs el-type
 283                                    &optional translate #!+gengc (remember t))
 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 addq index object lip)
 298          (inst stl 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 stl value (- (* (+ ,offset index) n-word-bytes) ,lowtag)
 315                object)
 316          (move value result)))))
 317
 318
 319 (defmacro define-partial-reffer (name type size signed offset lowtag scs
 320                                       el-type &optional translate)
 321   (let ((scale (ecase size (:byte 1) (:short 2))))
 322     `(progn
 323        (define-vop (,name)
 324          ,@(when translate
 325              `((:translate ,translate)))
 326          (:policy :fast-safe)
 327          (:args (object :scs (descriptor-reg))
 328                 (index :scs (unsigned-reg)))
 329          (:arg-types ,type positive-fixnum)
 330          (:results (value :scs ,scs))
 331          (:result-types ,el-type)
 332          (:temporary (:scs (interior-reg)) lip)
 333          (:temporary (:sc non-descriptor-reg) temp)
 334          (:temporary (:sc non-descriptor-reg) temp1)
 335          (:generator 5
 336            (inst addq object index lip)
 337            ,@(when (eq size :short)
 338                '((inst addq index lip lip)))
 339            ,@(ecase size
 340                (:byte
 341                 (if signed
 342                     `((inst ldq_u temp (- (* ,offset n-word-bytes) ,lowtag)
 343                             lip)
 344                       (inst lda temp1 (1+ (- (* ,offset n-word-bytes) ,lowtag))
 345                             lip)
 346                       (inst extqh temp temp1 temp)
 347                       (inst sra temp 56 value))
 348                     `((inst ldq_u
 349                             temp
 350                             (- (* ,offset n-word-bytes) ,lowtag)
 351                             lip)
 352                       (inst lda temp1 (- (* ,offset n-word-bytes) ,lowtag)
 353                                           lip)
 354                       (inst extbl temp temp1 value))))
 355                (:short
 356                 (if signed
 357                     `((inst ldq_u temp (- (* ,offset n-word-bytes) ,lowtag)
 358                             lip)
 359                       (inst lda temp1 (- (* ,offset n-word-bytes) ,lowtag)
 360                             lip)
 361                       (inst extwl temp temp1 temp)
 362                       (inst sll temp 48 temp)
 363                       (inst sra temp 48 value))
 364                     `((inst ldq_u temp (- (* ,offset n-word-bytes) ,lowtag)
 365                             lip)
 366                       (inst lda temp1 (- (* ,offset n-word-bytes) ,lowtag) lip)
 367                       (inst extwl temp temp1 value)))))))
 368        (define-vop (,(symbolicate name "-C"))
 369          ,@(when translate
 370              `((:translate ,translate)))
 371          (:policy :fast-safe)
 372          (:args (object :scs (descriptor-reg)))
 373          (:info index)
 374          (:arg-types ,type
 375                      (:constant (load/store-index ,scale
 376                                                   ,(eval lowtag)
 377                                                   ,(eval offset))))
 378          (:results (value :scs ,scs))
 379          (:result-types ,el-type)
 380          (:temporary (:sc non-descriptor-reg) temp)
 381          (:temporary (:sc non-descriptor-reg) temp1)
 382          (:generator 4
 383            ,@(ecase size
 384                (:byte
 385                 (if signed
 386                     `((inst ldq_u temp (- (+ (* ,offset n-word-bytes)
 387                                              (* index ,scale)) ,lowtag)
 388                             object)
 389                       (inst lda temp1 (1+ (- (+ (* ,offset n-word-bytes)
 390                                                 (* index ,scale)) ,lowtag))
 391                             object)
 392                       (inst extqh temp temp1 temp)
 393                       (inst sra temp 56 value))
 394                     `((inst ldq_u temp (- (+ (* ,offset n-word-bytes)
 395                                              (* index ,scale)) ,lowtag)
 396                             object)
 397                       (inst lda temp1 (- (+ (* ,offset n-word-bytes)
 398                                             (* index ,scale)) ,lowtag)
 399                             object)
 400                       (inst extbl temp temp1 value))))
 401                (:short
 402                 (if signed
 403                     `((inst ldq_u temp (- (+ (* ,offset n-word-bytes)
 404                                              (* index ,scale)) ,lowtag)
 405                             object)
 406                       (inst lda temp1 (- (+ (* ,offset n-word-bytes)
 407                                             (* index ,scale)) ,lowtag)
 408                             object)
 409                       (inst extwl temp temp1 temp)
 410                       (inst sll temp 48 temp)
 411                       (inst sra temp 48 value))
 412                     `((inst ldq_u temp (- (+ (* ,offset n-word-bytes)
 413                                              (* index ,scale)) ,lowtag)
 414                             object)
 415                       (inst lda temp1 (- (+ (* ,offset n-word-bytes)
 416                                             (* index ,scale)) ,lowtag)
 417                             object)
 418                       (inst extwl temp temp1 value))))))))))
 419
 420 (defmacro define-partial-setter (name type size offset lowtag scs el-type
 421                                       &optional translate)
 422   (let ((scale (ecase size (:byte 1) (:short 2))))
 423     `(progn
 424        (define-vop (,name)
 425          ,@(when translate
 426              `((:translate ,translate)))
 427          (:policy :fast-safe)
 428          (:args (object :scs (descriptor-reg))
 429                 (index :scs (unsigned-reg))
 430                 (value :scs ,scs :target result))
 431          (:arg-types ,type positive-fixnum ,el-type)
 432          (:temporary (:scs (interior-reg)) lip)
 433          (:temporary (:sc non-descriptor-reg) temp)
 434          (:temporary (:sc non-descriptor-reg) temp1)
 435          (:temporary (:sc non-descriptor-reg) temp2)
 436          (:results (result :scs ,scs))
 437          (:result-types ,el-type)
 438          (:generator 5
 439            (inst addq object index lip)
 440            ,@(when (eq size :short)
 441                '((inst addq lip index lip)))
 442            ,@(ecase size
 443                (:byte
 444                 `((inst lda temp (- (* ,offset n-word-bytes) ,lowtag) lip)
 445                   (inst ldq_u temp1 (- (* ,offset n-word-bytes) ,lowtag) lip)
 446                   (inst insbl value  temp temp2)
 447                   (inst mskbl temp1 temp temp1)
 448                   (inst bis temp1 temp2 temp1)
 449                   (inst stq_u temp1 (- (* ,offset n-word-bytes) ,lowtag) lip)))
 450                (:short
 451                 `((inst lda temp (- (* ,offset n-word-bytes) ,lowtag) lip)
 452                   (inst ldq_u temp1 (- (* ,offset n-word-bytes) ,lowtag) lip)
 453                   (inst mskwl temp1 temp temp1)
 454                   (inst inswl value temp temp2)
 455                   (inst bis temp1 temp2 temp)
 456                   (inst stq_u temp (- (* ,offset n-word-bytes) ,lowtag) lip))))
 457            (move value result)))
 458        (define-vop (,(symbolicate name "-C"))
 459          ,@(when translate
 460              `((:translate ,translate)))
 461          (:policy :fast-safe)
 462          (:args (object :scs (descriptor-reg))
 463                 (value :scs ,scs :target result))
 464          (:info index)
 465          (:arg-types ,type
 466                      (:constant (load/store-index ,scale
 467                                                   ,(eval lowtag)
 468                                                   ,(eval offset)))
 469                      ,el-type)
 470          (:temporary (:sc non-descriptor-reg) temp)
 471          (:temporary (:sc non-descriptor-reg) temp1)
 472          (:temporary (:sc non-descriptor-reg) temp2)
 473          (:results (result :scs ,scs))
 474          (:result-types ,el-type)
 475          (:generator 4
 476            ,@(ecase size
 477                (:byte
 478                 `((inst lda temp (- (+ (* ,offset n-word-bytes)
 479                                        (* index ,scale))
 480                                     ,lowtag)
 481                         object)
 482                   (inst ldq_u temp1 (- (+ (* ,offset n-word-bytes)
 483                                           (* index ,scale))
 484                                        ,lowtag)
 485                         object)
 486                   (inst insbl value temp temp2)
 487                   (inst mskbl temp1 temp temp1)
 488                   (inst bis temp1 temp2 temp1)
 489                   (inst stq_u temp1 (- (+ (* ,offset n-word-bytes)
 490                                           (* index ,scale))
 491                                        ,lowtag) object)))
 492                (:short
 493                 `((inst lda temp (- (+ (* ,offset n-word-bytes)
 494                                        (* index ,scale))
 495                                     ,lowtag)
 496                         object)
 497                   (inst ldq_u temp1 (- (+ (* ,offset n-word-bytes)
 498                                           (* index ,scale))
 499                                        ,lowtag)
 500                         object)
 501                   (inst mskwl temp1 temp temp1)
 502                   (inst inswl value temp temp2)
 503                   (inst bis temp1 temp2 temp)
 504                   (inst stq_u temp (- (+ (* ,offset n-word-bytes)
 505                                          (* index ,scale))
 506                                       ,lowtag) object))))
 507            (move value result))))))
 508
 509 (defmacro sb!sys::with-pinned-objects ((&rest objects) &body body)
 510   "Arrange with the garbage collector that the pages occupied by
 511 OBJECTS will not be moved in memory for the duration of BODY.
 512 Useful for e.g. foreign calls where another thread may trigger
 513 garbage collection.  This is currently implemented by disabling GC"
 514   (declare (ignore objects))            ;should we eval these for side-effect?
 515   `(without-gcing
 516     ,@body))