src/compiler/mips/macros.lisp

   1 ;;;; various useful macros for generating MIPS 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 (in-package "SB!VM")
  12
  13 ;;; Handy macro for defining top-level forms that depend on the compile
  14 ;;; environment.
  15
  16 (defmacro expand (expr)
  17   (let ((gensym (gensym)))
  18     `(macrolet
  19          ((,gensym ()
  20             ,expr))
  21        (,gensym))))
  22
  23 \f
  24 ;;; Instruction-like macros.
  25
  26 (defmacro move (dst src &optional (always-emit-code-p nil))
  27   "Move SRC into DST (unless they are location= and ALWAYS-EMIT-CODE-P
  28   is nil)."
  29   (once-only ((n-dst dst)
  30               (n-src src))
  31     (if always-emit-code-p
  32         `(inst move ,n-dst ,n-src)
  33         `(unless (location= ,n-dst ,n-src)
  34            (inst move ,n-dst ,n-src)))))
  35
  36 (defmacro def-mem-op (op inst shift load)
  37   `(defmacro ,op (object base &optional (offset 0) (lowtag 0))
  38      `(progn
  39         (inst ,',inst ,object ,base (- (ash ,offset ,,shift) ,lowtag))
  40         ,,@(when load '('(inst nop))))))
  41 ;;;
  42 (def-mem-op loadw lw word-shift t)
  43 (def-mem-op storew sw word-shift nil)
  44
  45 (defmacro load-symbol (reg symbol)
  46   `(inst addu ,reg null-tn (static-symbol-offset ,symbol)))
  47
  48 (defmacro load-symbol-value (reg symbol)
  49   `(progn
  50      (inst lw ,reg null-tn
  51            (+ (static-symbol-offset ',symbol)
  52               (ash symbol-value-slot word-shift)
  53               (- other-pointer-lowtag)))
  54      (inst nop)))
  55
  56 (defmacro store-symbol-value (reg symbol)
  57   `(inst sw ,reg null-tn
  58          (+ (static-symbol-offset ',symbol)
  59             (ash symbol-value-slot word-shift)
  60             (- other-pointer-lowtag))))
  61
  62 (defmacro load-type (target source &optional (offset 0))
  63   "Loads the type bits of a pointer into target independent of
  64   byte-ordering issues."
  65   (once-only ((n-target target)
  66               (n-source source)
  67               (n-offset offset))
  68     (ecase *backend-byte-order*
  69       (:little-endian
  70        `(inst lbu ,n-target ,n-source ,n-offset ))
  71       (:big-endian
  72        `(inst lbu ,n-target ,n-source (+ ,n-offset 3))))))
  73
  74
  75 ;;; Macros to handle the fact that we cannot use the machine native call and
  76 ;;; return instructions.
  77
  78 (defmacro lisp-jump (function lip)
  79   "Jump to the lisp function FUNCTION.  LIP is an interior-reg temporary."
  80   `(progn
  81      (inst addu ,lip ,function (- (ash simple-fun-code-offset word-shift)
  82                                    fun-pointer-lowtag))
  83      (inst j ,lip)
  84      (move code-tn ,function)))
  85
  86 (defmacro lisp-return (return-pc lip &key (offset 0) (frob-code t))
  87   "Return to RETURN-PC.  LIP is an interior-reg temporary."
  88   `(progn
  89      (inst addu ,lip ,return-pc
  90            (- (* (1+ ,offset) n-word-bytes) other-pointer-lowtag))
  91      (inst j ,lip)
  92      ,(if frob-code
  93           `(move code-tn ,return-pc)
  94           '(inst nop))))
  95
  96
  97 (defmacro emit-return-pc (label)
  98   "Emit a return-pc header word.  LABEL is the label to use for this return-pc."
  99   `(progn
 100      (align n-lowtag-bits)
 101      (emit-label ,label)
 102      (inst lra-header-word)))
 103
 104
 105 \f
 106 ;;;; Stack TN's
 107
 108 ;;; Load-Stack-TN, Store-Stack-TN  --  Interface
 109 ;;;
 110 ;;;    Move a stack TN to a register and vice-versa.
 111 (defmacro load-stack-tn (reg stack)
 112   `(let ((reg ,reg)
 113          (stack ,stack))
 114      (let ((offset (tn-offset stack)))
 115        (sc-case stack
 116          ((control-stack)
 117           (loadw reg cfp-tn offset))))))
 118
 119 (defmacro store-stack-tn (stack reg)
 120   `(let ((stack ,stack)
 121          (reg ,reg))
 122      (let ((offset (tn-offset stack)))
 123        (sc-case stack
 124          ((control-stack)
 125           (storew reg cfp-tn offset))))))
 126
 127 (defmacro maybe-load-stack-tn (reg reg-or-stack)
 128   "Move the TN Reg-Or-Stack into Reg if it isn't already there."
 129   (once-only ((n-reg reg)
 130               (n-stack reg-or-stack))
 131     `(sc-case ,n-reg
 132        ((any-reg descriptor-reg)
 133         (sc-case ,n-stack
 134           ((any-reg descriptor-reg)
 135            (move ,n-reg ,n-stack))
 136           ((control-stack)
 137            (loadw ,n-reg cfp-tn (tn-offset ,n-stack))))))))
 138
 139 \f
 140 ;;;; Storage allocation:
 141 (defmacro with-fixed-allocation ((result-tn flag-tn temp-tn type-code size)
 142                                  &body body)
 143   "Do stuff to allocate an other-pointer object of fixed Size with a single
 144    word header having the specified Type-Code.  The result is placed in
 145    Result-TN, Flag-Tn must be wired to NL3-OFFSET, and Temp-TN is a non-
 146    descriptor temp (which may be randomly used by the body.)  The body is
 147    placed inside the PSEUDO-ATOMIC, and presumably initializes the object."
 148   `(pseudo-atomic (,flag-tn :extra (pad-data-block ,size))
 149      (inst or ,result-tn alloc-tn other-pointer-lowtag)
 150      (inst li ,temp-tn (logior (ash (1- ,size) n-widetag-bits) ,type-code))
 151      (storew ,temp-tn ,result-tn 0 other-pointer-lowtag)
 152      ,@body))
 153
 154
 155 \f
 156 ;;;; Three Way Comparison
 157 (defun three-way-comparison (x y condition flavor not-p target temp)
 158   (ecase condition
 159     (:eq
 160      (if not-p
 161          (inst bne x y target)
 162          (inst beq x y target)))
 163     (:lt
 164      (ecase flavor
 165        (:unsigned
 166         (inst sltu temp x y))
 167        (:signed
 168         (inst slt temp x y)))
 169      (if not-p
 170          (inst beq temp zero-tn target)
 171          (inst bne temp zero-tn target)))
 172     (:gt
 173      (ecase flavor
 174        (:unsigned
 175         (inst sltu temp y x))
 176        (:signed
 177         (inst slt temp y x)))
 178      (if not-p
 179          (inst beq temp zero-tn target)
 180          (inst bne temp zero-tn target))))
 181   (inst nop))
 182
 183
 184 \f
 185 ;;;; Error Code
 186 (eval-when (compile load eval)
 187   (defun emit-error-break (vop kind code values)
 188     (let ((vector (gensym)))
 189       `((let ((vop ,vop))
 190           (when vop
 191             (note-this-location vop :internal-error)))
 192         (inst break ,kind)
 193         (with-adjustable-vector (,vector)
 194           (write-var-integer (error-number-or-lose ',code) ,vector)
 195           ,@(mapcar #'(lambda (tn)
 196                         `(let ((tn ,tn))
 197                            (write-var-integer (make-sc-offset (sc-number
 198                                                                (tn-sc tn))
 199                                                               (tn-offset tn))
 200                                               ,vector)))
 201                     values)
 202           (inst byte (length ,vector))
 203           (dotimes (i (length ,vector))
 204             (inst byte (aref ,vector i))))
 205         (align word-shift)))))
 206
 207 (defmacro error-call (vop error-code &rest values)
 208   "Cause an error.  ERROR-CODE is the error to cause."
 209   (cons 'progn
 210         (emit-error-break vop error-trap error-code values)))
 211
 212
 213 (defmacro cerror-call (vop label error-code &rest values)
 214   "Cause a continuable error.  If the error is continued, execution resumes at
 215   LABEL."
 216   `(progn
 217      (inst b ,label)
 218      ,@(emit-error-break vop cerror-trap error-code values)))
 219
 220 (defmacro generate-error-code (vop error-code &rest values)
 221   "Generate-Error-Code Error-code Value*
 222   Emit code for an error with the specified Error-Code and context Values."
 223   `(assemble (*elsewhere*)
 224      (let ((start-lab (gen-label)))
 225        (emit-label start-lab)
 226        (error-call ,vop ,error-code ,@values)
 227        start-lab)))
 228
 229 (defmacro generate-cerror-code (vop error-code &rest values)
 230   "Generate-CError-Code Error-code Value*
 231   Emit code for a continuable error with the specified Error-Code and
 232   context Values.  If the error is continued, execution resumes after
 233   the GENERATE-CERROR-CODE form."
 234   (let ((continue (gensym "CONTINUE-LABEL-"))
 235         (error (gensym "ERROR-LABEL-")))
 236     `(let ((,continue (gen-label)))
 237        (emit-label ,continue)
 238        (assemble (*elsewhere*)
 239          (let ((,error (gen-label)))
 240            (emit-label ,error)
 241            (cerror-call ,vop ,continue ,error-code ,@values)
 242            ,error)))))
 243
 244 \f
 245 ;;; PSEUDO-ATOMIC -- Handy macro for making sequences look atomic.
 246 (defmacro pseudo-atomic ((flag-tn &key (extra 0)) &rest forms)
 247   `(progn
 248      (aver (= (tn-offset ,flag-tn) nl4-offset))
 249      (aver (not (minusp ,extra)))
 250      (without-scheduling ()
 251        (inst li ,flag-tn ,extra)
 252        (inst addu alloc-tn 1))
 253      ,@forms
 254      (without-scheduling ()
 255        (let ((label (gen-label)))
 256          (inst nop)
 257          (inst nop)
 258          (inst nop)
 259          (inst bgez ,flag-tn label)
 260          (inst addu alloc-tn (1- ,extra))
 261          (inst break 16)
 262          (emit-label label)))))
 263
 264
 265 \f
 266 ;;;; Memory accessor vop generators
 267
 268 (deftype load/store-index (scale lowtag min-offset
 269                                  &optional (max-offset min-offset))
 270   `(integer ,(- (truncate (+ (ash 1 16)
 271                              (* min-offset n-word-bytes)
 272                              (- lowtag))
 273                           scale))
 274             ,(truncate (- (+ (1- (ash 1 16)) lowtag)
 275                           (* max-offset n-word-bytes))
 276                        scale)))
 277
 278 (defmacro define-full-reffer (name type offset lowtag scs el-type
 279                                    &optional translate)
 280   `(progn
 281      (define-vop (,name)
 282        ,@(when translate
 283            `((:translate ,translate)))
 284        (:policy :fast-safe)
 285        (:args (object :scs (descriptor-reg))
 286               (index :scs (any-reg)))
 287        (:arg-types ,type tagged-num)
 288        (:temporary (:scs (interior-reg)) lip)
 289        (:results (value :scs ,scs))
 290        (:result-types ,el-type)
 291        (:generator 5
 292          (inst add lip object index)
 293          (inst lw value lip (- (* ,offset n-word-bytes) ,lowtag))
 294          (inst nop)))
 295      (define-vop (,(symbolicate name "-C"))
 296        ,@(when translate
 297            `((:translate ,translate)))
 298        (:policy :fast-safe)
 299        (:args (object :scs (descriptor-reg)))
 300        (:info index)
 301        (:arg-types ,type
 302                    (:constant (load/store-index ,n-word-bytes ,(eval lowtag)
 303                                                 ,(eval offset))))
 304        (:results (value :scs ,scs))
 305        (:result-types ,el-type)
 306        (:generator 4
 307          (inst lw value object (- (* (+ ,offset index) n-word-bytes) ,lowtag))
 308          (inst nop)))))
 309
 310 (defmacro define-full-setter (name type offset lowtag scs el-type
 311                                    &optional translate)
 312   `(progn
 313      (define-vop (,name)
 314        ,@(when translate
 315            `((:translate ,translate)))
 316        (:policy :fast-safe)
 317        (:args (object :scs (descriptor-reg))
 318               (index :scs (any-reg))
 319               (value :scs ,scs :target result))
 320        (:arg-types ,type tagged-num ,el-type)
 321        (:temporary (:scs (interior-reg)) lip)
 322        (:results (result :scs ,scs))
 323        (:result-types ,el-type)
 324        (:generator 2
 325          (inst add lip object index)
 326          (inst sw value lip (- (* ,offset n-word-bytes) ,lowtag))
 327          (move result value)))
 328      (define-vop (,(symbolicate name "-C"))
 329        ,@(when translate
 330            `((:translate ,translate)))
 331        (:policy :fast-safe)
 332        (:args (object :scs (descriptor-reg))
 333               (value :scs ,scs))
 334        (:info index)
 335        (:arg-types ,type
 336                    (:constant (load/store-index ,n-word-bytes ,(eval lowtag)
 337                                                 ,(eval offset)))
 338                    ,el-type)
 339        (:results (result :scs ,scs))
 340        (:result-types ,el-type)
 341        (:generator 1
 342          (inst sw value object (- (* (+ ,offset index) n-word-bytes) ,lowtag))
 343          (move result value)))))
 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          (:generator 5
 361            (inst addu lip object index)
 362            ,@(when (eq size :short)
 363                '((inst addu lip index)))
 364            (inst ,(ecase size
 365                     (:byte (if signed 'lb 'lbu))
 366                     (:short (if signed 'lh 'lhu)))
 367                  value lip (- (* ,offset n-word-bytes) ,lowtag))
 368            (inst nop)))
 369        (define-vop (,(symbolicate name "-C"))
 370          ,@(when translate
 371              `((:translate ,translate)))
 372          (:policy :fast-safe)
 373          (:args (object :scs (descriptor-reg)))
 374          (:info index)
 375          (:arg-types ,type
 376                      (:constant (load/store-index ,scale
 377                                                   ,(eval lowtag)
 378                                                   ,(eval offset))))
 379          (:results (value :scs ,scs))
 380          (:result-types ,el-type)
 381          (:generator 5
 382            (inst ,(ecase size
 383                     (:byte (if signed 'lb 'lbu))
 384                     (:short (if signed 'lh 'lhu)))
 385                  value object
 386                  (- (+ (* ,offset n-word-bytes) (* index ,scale)) ,lowtag))
 387            (inst nop))))))
 388
 389 (defmacro define-partial-setter (name type size offset lowtag scs el-type
 390                                       &optional translate)
 391   (let ((scale (ecase size (:byte 1) (:short 2))))
 392     `(progn
 393        (define-vop (,name)
 394          ,@(when translate
 395              `((:translate ,translate)))
 396          (:policy :fast-safe)
 397          (:args (object :scs (descriptor-reg))
 398                 (index :scs (unsigned-reg))
 399                 (value :scs ,scs :target result))
 400          (:arg-types ,type positive-fixnum ,el-type)
 401          (:temporary (:scs (interior-reg)) lip)
 402          (:results (result :scs ,scs))
 403          (:result-types ,el-type)
 404          (:generator 5
 405            (inst addu lip object index)
 406            ,@(when (eq size :short)
 407                '((inst addu lip index)))
 408            (inst ,(ecase size (:byte 'sb) (:short 'sh))
 409                  value lip (- (* ,offset n-word-bytes) ,lowtag))
 410            (move result value)))
 411        (define-vop (,(symbolicate name "-C"))
 412          ,@(when translate
 413              `((:translate ,translate)))
 414          (:policy :fast-safe)
 415          (:args (object :scs (descriptor-reg))
 416                 (value :scs ,scs :target result))
 417          (:info index)
 418          (:arg-types ,type
 419                      (:constant (load/store-index ,scale
 420                                                   ,(eval lowtag)
 421                                                   ,(eval offset)))
 422                      ,el-type)
 423          (:results (result :scs ,scs))
 424          (:result-types ,el-type)
 425          (:generator 5
 426            (inst ,(ecase size (:byte 'sb) (:short 'sh))
 427                  value object
 428                  (- (* ,offset n-word-bytes) (* index ,scale) ,lowtag))
 429            (move result value))))))
 430