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   (unless body
 173     (bug "empty &body in WITH-FIXED-ALLOCATION"))
 174   (once-only ((result-tn result-tn) (temp-tn temp-tn) (size size))
 175     `(pseudo-atomic (:extra (pad-data-block ,size))
 176        (inst bis alloc-tn other-pointer-lowtag ,result-tn)
 177        (inst li (logior (ash (1- ,size) n-widetag-bits) ,widetag) ,temp-tn)
 178        (storew ,temp-tn ,result-tn 0 other-pointer-lowtag)
 179        ,@body)))
 180 \f
 181 ;;;; error code
 182 (eval-when (:compile-toplevel :load-toplevel :execute)
 183   (defun emit-error-break (vop kind code values)
 184     (let ((vector (gensym)))
 185       `((let ((vop ,vop))
 186           (when vop
 187             (note-this-location vop :internal-error)))
 188         (inst gentrap ,kind)
 189         (with-adjustable-vector (,vector)
 190           (write-var-integer (error-number-or-lose ',code) ,vector)
 191           ,@(mapcar (lambda (tn)
 192                       `(let ((tn ,tn))
 193                          (write-var-integer (make-sc-offset (sc-number
 194                                                              (tn-sc tn))
 195                                                             (tn-offset tn))
 196                                             ,vector)))
 197                     values)
 198           (inst byte (length ,vector))
 199           (dotimes (i (length ,vector))
 200             (inst byte (aref ,vector i))))
 201         (align word-shift)))))
 202
 203 (defmacro error-call (vop error-code &rest values)
 204   "Cause an error.  ERROR-CODE is the error to cause."
 205   (cons 'progn
 206         (emit-error-break vop error-trap error-code values)))
 207
 208
 209 (defmacro cerror-call (vop label error-code &rest values)
 210   "Cause a continuable error.  If the error is continued, execution resumes at
 211   LABEL."
 212   `(progn
 213      (inst br zero-tn ,label)
 214      ,@(emit-error-break vop cerror-trap error-code values)))
 215
 216 (defmacro generate-error-code (vop error-code &rest values)
 217   "Generate-Error-Code Error-code Value*
 218   Emit code for an error with the specified Error-Code and context Values."
 219   `(assemble (*elsewhere*)
 220      (let ((start-lab (gen-label)))
 221        (emit-label start-lab)
 222        (error-call ,vop ,error-code ,@values)
 223        start-lab)))
 224
 225 (defmacro generate-cerror-code (vop error-code &rest values)
 226   "Generate-CError-Code Error-code Value*
 227   Emit code for a continuable error with the specified Error-Code and
 228   context Values.  If the error is continued, execution resumes after
 229   the GENERATE-CERROR-CODE form."
 230   (with-unique-names (continue error)
 231     `(let ((,continue (gen-label)))
 232        (emit-label ,continue)
 233        (assemble (*elsewhere*)
 234          (let ((,error (gen-label)))
 235            (emit-label ,error)
 236            (cerror-call ,vop ,continue ,error-code ,@values)
 237            ,error)))))
 238
 239 \f
 240 ;;; a handy macro for making sequences look atomic
 241 (defmacro pseudo-atomic ((&key (extra 0)) &rest forms)
 242   `(progn
 243      (inst addq alloc-tn 1 alloc-tn)
 244      ,@forms
 245      (inst lda alloc-tn (1- ,extra) alloc-tn)
 246      (inst stl zero-tn 0 alloc-tn)))
 247 \f
 248 ;;;; memory accessor vop generators
 249
 250 (defmacro define-full-reffer (name type offset lowtag scs el-type
 251                                    &optional translate)
 252   `(progn
 253      (define-vop (,name)
 254        ,@(when translate
 255            `((:translate ,translate)))
 256        (:policy :fast-safe)
 257        (:args (object :scs (descriptor-reg))
 258               (index :scs (any-reg)))
 259        (:arg-types ,type tagged-num)
 260        (:temporary (:scs (interior-reg)) lip)
 261        (:results (value :scs ,scs))
 262        (:result-types ,el-type)
 263        (:generator 5
 264          (inst addq object index lip)
 265          (inst ldl value (- (* ,offset n-word-bytes) ,lowtag) lip)
 266          ,@(when (equal scs '(unsigned-reg))
 267              '((inst mskll value 4 value)))))
 268      (define-vop (,(symbolicate name "-C"))
 269        ,@(when translate
 270            `((:translate ,translate)))
 271        (:policy :fast-safe)
 272        (:args (object :scs (descriptor-reg)))
 273        (:info index)
 274        (:arg-types ,type
 275                    (:constant (load/store-index ,n-word-bytes ,(eval lowtag)
 276                                                 ,(eval offset))))
 277        (:results (value :scs ,scs))
 278        (:result-types ,el-type)
 279        (:generator 4
 280          (inst ldl value (- (* (+ ,offset index) n-word-bytes) ,lowtag)
 281                object)
 282          ,@(when (equal scs '(unsigned-reg))
 283              '((inst mskll value 4 value)))))))
 284
 285 (defmacro define-full-setter (name type offset lowtag scs el-type
 286                                    &optional translate #!+gengc (remember t))
 287   `(progn
 288      (define-vop (,name)
 289        ,@(when translate
 290            `((:translate ,translate)))
 291        (:policy :fast-safe)
 292        (:args (object :scs (descriptor-reg))
 293               (index :scs (any-reg))
 294               (value :scs ,scs :target result))
 295        (:arg-types ,type tagged-num ,el-type)
 296        (:temporary (:scs (interior-reg)) lip)
 297        (:results (result :scs ,scs))
 298        (:result-types ,el-type)
 299        (:generator 2
 300          (inst addq index object lip)
 301          (inst stl value (- (* ,offset n-word-bytes) ,lowtag) lip)
 302          (move value result)))
 303      (define-vop (,(symbolicate name "-C"))
 304        ,@(when translate
 305            `((:translate ,translate)))
 306        (:policy :fast-safe)
 307        (:args (object :scs (descriptor-reg))
 308               (value :scs ,scs))
 309        (:info index)
 310        (:arg-types ,type
 311                    (:constant (load/store-index ,n-word-bytes ,(eval lowtag)
 312                                                 ,(eval offset)))
 313                    ,el-type)
 314        (:results (result :scs ,scs))
 315        (:result-types ,el-type)
 316        (:generator 1
 317          (inst stl value (- (* (+ ,offset index) n-word-bytes) ,lowtag)
 318                object)
 319          (move value result)))))
 320
 321
 322 (defmacro define-partial-reffer (name type size signed offset lowtag scs
 323                                       el-type &optional translate)
 324   (let ((scale (ecase size (:byte 1) (:short 2))))
 325     `(progn
 326        (define-vop (,name)
 327          ,@(when translate
 328              `((:translate ,translate)))
 329          (:policy :fast-safe)
 330          (:args (object :scs (descriptor-reg))
 331                 (index :scs (unsigned-reg)))
 332          (:arg-types ,type positive-fixnum)
 333          (:results (value :scs ,scs))
 334          (:result-types ,el-type)
 335          (:temporary (:scs (interior-reg)) lip)
 336          (:temporary (:sc non-descriptor-reg) temp)
 337          (:temporary (:sc non-descriptor-reg) temp1)
 338          (:generator 5
 339            (inst addq object index lip)
 340            ,@(when (eq size :short)
 341                '((inst addq index lip lip)))
 342            ,@(ecase size
 343                (:byte
 344                 (if signed
 345                     `((inst ldq_u temp (- (* ,offset n-word-bytes) ,lowtag)
 346                             lip)
 347                       (inst lda temp1 (1+ (- (* ,offset n-word-bytes) ,lowtag))
 348                             lip)
 349                       (inst extqh temp temp1 temp)
 350                       (inst sra temp 56 value))
 351                     `((inst ldq_u
 352                             temp
 353                             (- (* ,offset n-word-bytes) ,lowtag)
 354                             lip)
 355                       (inst lda temp1 (- (* ,offset n-word-bytes) ,lowtag)
 356                                           lip)
 357                       (inst extbl temp temp1 value))))
 358                (:short
 359                 (if signed
 360                     `((inst ldq_u temp (- (* ,offset n-word-bytes) ,lowtag)
 361                             lip)
 362                       (inst lda temp1 (- (* ,offset n-word-bytes) ,lowtag)
 363                             lip)
 364                       (inst extwl temp temp1 temp)
 365                       (inst sll temp 48 temp)
 366                       (inst sra temp 48 value))
 367                     `((inst ldq_u temp (- (* ,offset n-word-bytes) ,lowtag)
 368                             lip)
 369                       (inst lda temp1 (- (* ,offset n-word-bytes) ,lowtag) lip)
 370                       (inst extwl temp temp1 value)))))))
 371        (define-vop (,(symbolicate name "-C"))
 372          ,@(when translate
 373              `((:translate ,translate)))
 374          (:policy :fast-safe)
 375          (:args (object :scs (descriptor-reg)))
 376          (:info index)
 377          (:arg-types ,type
 378                      (:constant (load/store-index ,scale
 379                                                   ,(eval lowtag)
 380                                                   ,(eval offset))))
 381          (:results (value :scs ,scs))
 382          (:result-types ,el-type)
 383          (:temporary (:sc non-descriptor-reg) temp)
 384          (:temporary (:sc non-descriptor-reg) temp1)
 385          (:generator 4
 386            ,@(ecase size
 387                (:byte
 388                 (if signed
 389                     `((inst ldq_u temp (- (+ (* ,offset n-word-bytes)
 390                                              (* index ,scale)) ,lowtag)
 391                             object)
 392                       (inst lda temp1 (1+ (- (+ (* ,offset n-word-bytes)
 393                                                 (* index ,scale)) ,lowtag))
 394                             object)
 395                       (inst extqh temp temp1 temp)
 396                       (inst sra temp 56 value))
 397                     `((inst ldq_u temp (- (+ (* ,offset n-word-bytes)
 398                                              (* index ,scale)) ,lowtag)
 399                             object)
 400                       (inst lda temp1 (- (+ (* ,offset n-word-bytes)
 401                                             (* index ,scale)) ,lowtag)
 402                             object)
 403                       (inst extbl temp temp1 value))))
 404                (:short
 405                 (if signed
 406                     `((inst ldq_u temp (- (+ (* ,offset n-word-bytes)
 407                                              (* index ,scale)) ,lowtag)
 408                             object)
 409                       (inst lda temp1 (- (+ (* ,offset n-word-bytes)
 410                                             (* index ,scale)) ,lowtag)
 411                             object)
 412                       (inst extwl temp temp1 temp)
 413                       (inst sll temp 48 temp)
 414                       (inst sra temp 48 value))
 415                     `((inst ldq_u temp (- (+ (* ,offset n-word-bytes)
 416                                              (* index ,scale)) ,lowtag)
 417                             object)
 418                       (inst lda temp1 (- (+ (* ,offset n-word-bytes)
 419                                             (* index ,scale)) ,lowtag)
 420                             object)
 421                       (inst extwl temp temp1 value))))))))))
 422
 423 (defmacro define-partial-setter (name type size offset lowtag scs el-type
 424                                       &optional translate)
 425   (let ((scale (ecase size (:byte 1) (:short 2))))
 426     `(progn
 427        (define-vop (,name)
 428          ,@(when translate
 429              `((:translate ,translate)))
 430          (:policy :fast-safe)
 431          (:args (object :scs (descriptor-reg))
 432                 (index :scs (unsigned-reg))
 433                 (value :scs ,scs :target result))
 434          (:arg-types ,type positive-fixnum ,el-type)
 435          (:temporary (:scs (interior-reg)) lip)
 436          (:temporary (:sc non-descriptor-reg) temp)
 437          (:temporary (:sc non-descriptor-reg) temp1)
 438          (:temporary (:sc non-descriptor-reg) temp2)
 439          (:results (result :scs ,scs))
 440          (:result-types ,el-type)
 441          (:generator 5
 442            (inst addq object index lip)
 443            ,@(when (eq size :short)
 444                '((inst addq lip index lip)))
 445            ,@(ecase size
 446                (:byte
 447                 `((inst lda temp (- (* ,offset n-word-bytes) ,lowtag) lip)
 448                   (inst ldq_u temp1 (- (* ,offset n-word-bytes) ,lowtag) lip)
 449                   (inst insbl value  temp temp2)
 450                   (inst mskbl temp1 temp temp1)
 451                   (inst bis temp1 temp2 temp1)
 452                   (inst stq_u temp1 (- (* ,offset n-word-bytes) ,lowtag) lip)))
 453                (:short
 454                 `((inst lda temp (- (* ,offset n-word-bytes) ,lowtag) lip)
 455                   (inst ldq_u temp1 (- (* ,offset n-word-bytes) ,lowtag) lip)
 456                   (inst mskwl temp1 temp temp1)
 457                   (inst inswl value temp temp2)
 458                   (inst bis temp1 temp2 temp)
 459                   (inst stq_u temp (- (* ,offset n-word-bytes) ,lowtag) lip))))
 460            (move value result)))
 461        (define-vop (,(symbolicate name "-C"))
 462          ,@(when translate
 463              `((:translate ,translate)))
 464          (:policy :fast-safe)
 465          (:args (object :scs (descriptor-reg))
 466                 (value :scs ,scs :target result))
 467          (:info index)
 468          (:arg-types ,type
 469                      (:constant (load/store-index ,scale
 470                                                   ,(eval lowtag)
 471                                                   ,(eval offset)))
 472                      ,el-type)
 473          (:temporary (:sc non-descriptor-reg) temp)
 474          (:temporary (:sc non-descriptor-reg) temp1)
 475          (:temporary (:sc non-descriptor-reg) temp2)
 476          (:results (result :scs ,scs))
 477          (:result-types ,el-type)
 478          (:generator 4
 479            ,@(ecase size
 480                (:byte
 481                 `((inst lda temp (- (+ (* ,offset n-word-bytes)
 482                                        (* index ,scale))
 483                                     ,lowtag)
 484                         object)
 485                   (inst ldq_u temp1 (- (+ (* ,offset n-word-bytes)
 486                                           (* index ,scale))
 487                                        ,lowtag)
 488                         object)
 489                   (inst insbl value temp temp2)
 490                   (inst mskbl temp1 temp temp1)
 491                   (inst bis temp1 temp2 temp1)
 492                   (inst stq_u temp1 (- (+ (* ,offset n-word-bytes)
 493                                           (* index ,scale))
 494                                        ,lowtag) object)))
 495                (:short
 496                 `((inst lda temp (- (+ (* ,offset n-word-bytes)
 497                                        (* index ,scale))
 498                                     ,lowtag)
 499                         object)
 500                   (inst ldq_u temp1 (- (+ (* ,offset n-word-bytes)
 501                                           (* index ,scale))
 502                                        ,lowtag)
 503                         object)
 504                   (inst mskwl temp1 temp temp1)
 505                   (inst inswl value temp temp2)
 506                   (inst bis temp1 temp2 temp)
 507                   (inst stq_u temp (- (+ (* ,offset n-word-bytes)
 508                                          (* index ,scale))
 509                                       ,lowtag) object))))
 510            (move value result))))))
 511
 512 (defmacro sb!sys::with-pinned-objects ((&rest objects) &body body)
 513   "Arrange with the garbage collector that the pages occupied by
 514 OBJECTS will not be moved in memory for the duration of BODY.
 515 Useful for e.g. foreign calls where another thread may trigger
 516 garbage collection.  This is currently implemented by disabling GC"
 517   (declare (ignore objects))            ;should we eval these for side-effect?
 518   `(without-gcing
 519     ,@body))