src/compiler/alpha/macros.lisp

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