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