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