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 ;;; Move a stack TN to a register and vice-versa.
 109 (defmacro load-stack-tn (reg stack)
 110   `(let ((reg ,reg)
 111          (stack ,stack))
 112      (let ((offset (tn-offset stack)))
 113        (sc-case stack
 114          ((control-stack)
 115           (loadw reg cfp-tn offset))))))
 116 (defmacro store-stack-tn (stack reg)
 117   `(let ((stack ,stack)
 118          (reg ,reg))
 119      (let ((offset (tn-offset stack)))
 120        (sc-case stack
 121          ((control-stack)
 122           (storew reg cfp-tn offset))))))
 123
 124 (defmacro maybe-load-stack-tn (reg reg-or-stack)
 125   "Move the TN Reg-Or-Stack into Reg if it isn't already there."
 126   (once-only ((n-reg reg)
 127               (n-stack reg-or-stack))
 128     `(sc-case ,n-reg
 129        ((any-reg descriptor-reg)
 130         (sc-case ,n-stack
 131           ((any-reg descriptor-reg)
 132            (move ,n-reg ,n-stack))
 133           ((control-stack)
 134            (loadw ,n-reg cfp-tn (tn-offset ,n-stack))))))))
 135
 136 \f
 137 ;;;; Storage allocation:
 138 (defmacro with-fixed-allocation ((result-tn flag-tn temp-tn type-code size)
 139                                  &body body)
 140   "Do stuff to allocate an other-pointer object of fixed Size with a single
 141    word header having the specified Type-Code.  The result is placed in
 142    Result-TN, Flag-Tn must be wired to NL3-OFFSET, and Temp-TN is a non-
 143    descriptor temp (which may be randomly used by the body.)  The body is
 144    placed inside the PSEUDO-ATOMIC, and presumably initializes the object."
 145   `(pseudo-atomic (,flag-tn :extra (pad-data-block ,size))
 146      (inst or ,result-tn alloc-tn other-pointer-lowtag)
 147      (inst li ,temp-tn (logior (ash (1- ,size) n-widetag-bits) ,type-code))
 148      (storew ,temp-tn ,result-tn 0 other-pointer-lowtag)
 149      ,@body))
 150
 151
 152 \f
 153 ;;;; Three Way Comparison
 154 (defun three-way-comparison (x y condition flavor not-p target temp)
 155   (ecase condition
 156     (:eq
 157      (if not-p
 158          (inst bne x y target)
 159          (inst beq x y target)))
 160     (:lt
 161      (ecase flavor
 162        (:unsigned
 163         (inst sltu temp x y))
 164        (:signed
 165         (inst slt temp x y)))
 166      (if not-p
 167          (inst beq temp zero-tn target)
 168          (inst bne temp zero-tn target)))
 169     (:gt
 170      (ecase flavor
 171        (:unsigned
 172         (inst sltu temp y x))
 173        (:signed
 174         (inst slt temp y x)))
 175      (if not-p
 176          (inst beq temp zero-tn target)
 177          (inst bne temp zero-tn target))))
 178   (inst nop))
 179
 180
 181 \f
 182 ;;;; Error Code
 183 (eval-when (compile load eval)
 184   (defun emit-error-break (vop kind code values)
 185     (let ((vector (gensym)))
 186       `((let ((vop ,vop))
 187           (when vop
 188             (note-this-location vop :internal-error)))
 189         (inst break ,kind)
 190         (with-adjustable-vector (,vector)
 191           (write-var-integer (error-number-or-lose ',code) ,vector)
 192           ,@(mapcar #'(lambda (tn)
 193                         `(let ((tn ,tn))
 194                            (write-var-integer (make-sc-offset (sc-number
 195                                                                (tn-sc tn))
 196                                                               (tn-offset tn))
 197                                               ,vector)))
 198                     values)
 199           (inst byte (length ,vector))
 200           (dotimes (i (length ,vector))
 201             (inst byte (aref ,vector i))))
 202         (align word-shift)))))
 203
 204 (defmacro error-call (vop error-code &rest values)
 205   "Cause an error.  ERROR-CODE is the error to cause."
 206   (cons 'progn
 207         (emit-error-break vop error-trap error-code values)))
 208
 209
 210 (defmacro cerror-call (vop label error-code &rest values)
 211   "Cause a continuable error.  If the error is continued, execution resumes at
 212   LABEL."
 213   `(progn
 214      (inst b ,label)
 215      ,@(emit-error-break vop cerror-trap error-code values)))
 216
 217 (defmacro generate-error-code (vop error-code &rest values)
 218   "Generate-Error-Code Error-code Value*
 219   Emit code for an error with the specified Error-Code and context Values."
 220   `(assemble (*elsewhere*)
 221      (let ((start-lab (gen-label)))
 222        (emit-label start-lab)
 223        (error-call ,vop ,error-code ,@values)
 224        start-lab)))
 225
 226 (defmacro generate-cerror-code (vop error-code &rest values)
 227   "Generate-CError-Code Error-code Value*
 228   Emit code for a continuable error with the specified Error-Code and
 229   context Values.  If the error is continued, execution resumes after
 230   the GENERATE-CERROR-CODE form."
 231   (with-unique-names (continue error)
 232     `(let ((,continue (gen-label)))
 233        (emit-label ,continue)
 234        (assemble (*elsewhere*)
 235          (let ((,error (gen-label)))
 236            (emit-label ,error)
 237            (cerror-call ,vop ,continue ,error-code ,@values)
 238            ,error)))))
 239 \f
 240 ;;;; PSEUDO-ATOMIC
 241
 242 ;;; handy macro for making sequences look atomic
 243 (defmacro pseudo-atomic ((flag-tn &key (extra 0)) &rest forms)
 244   `(progn
 245      (aver (= (tn-offset ,flag-tn) nl4-offset))
 246      (aver (not (minusp ,extra)))
 247      (without-scheduling ()
 248        (inst li ,flag-tn ,extra)
 249        (inst addu alloc-tn 1))
 250      ,@forms
 251      (without-scheduling ()
 252        (let ((label (gen-label)))
 253          (inst nop)
 254          (inst nop)
 255          (inst nop)
 256          (inst bgez ,flag-tn label)
 257          (inst addu alloc-tn (1- ,extra))
 258          (inst break 16)
 259          (emit-label label)))))
 260 \f
 261 ;;;; memory accessor vop generators
 262
 263 (deftype load/store-index (scale lowtag min-offset
 264                                  &optional (max-offset min-offset))
 265   `(integer ,(- (truncate (+ (ash 1 16)
 266                              (* min-offset n-word-bytes)
 267                              (- lowtag))
 268                           scale))
 269             ,(truncate (- (+ (1- (ash 1 16)) lowtag)
 270                           (* max-offset n-word-bytes))
 271                        scale)))
 272
 273 (defmacro define-full-reffer (name type offset lowtag scs el-type
 274                                    &optional translate)
 275   `(progn
 276      (define-vop (,name)
 277        ,@(when translate
 278            `((:translate ,translate)))
 279        (:policy :fast-safe)
 280        (:args (object :scs (descriptor-reg))
 281               (index :scs (any-reg)))
 282        (:arg-types ,type tagged-num)
 283        (:temporary (:scs (interior-reg)) lip)
 284        (:results (value :scs ,scs))
 285        (:result-types ,el-type)
 286        (:generator 5
 287          (inst add lip object index)
 288          (inst lw value lip (- (* ,offset n-word-bytes) ,lowtag))
 289          (inst nop)))
 290      (define-vop (,(symbolicate name "-C"))
 291        ,@(when translate
 292            `((:translate ,translate)))
 293        (:policy :fast-safe)
 294        (:args (object :scs (descriptor-reg)))
 295        (:info index)
 296        (:arg-types ,type
 297                    (:constant (load/store-index ,n-word-bytes ,(eval lowtag)
 298                                                 ,(eval offset))))
 299        (:results (value :scs ,scs))
 300        (:result-types ,el-type)
 301        (:generator 4
 302          (inst lw value object (- (* (+ ,offset index) n-word-bytes) ,lowtag))
 303          (inst nop)))))
 304
 305 (defmacro define-full-setter (name type offset lowtag scs el-type
 306                                    &optional translate)
 307   `(progn
 308      (define-vop (,name)
 309        ,@(when translate
 310            `((:translate ,translate)))
 311        (:policy :fast-safe)
 312        (:args (object :scs (descriptor-reg))
 313               (index :scs (any-reg))
 314               (value :scs ,scs :target result))
 315        (:arg-types ,type tagged-num ,el-type)
 316        (:temporary (:scs (interior-reg)) lip)
 317        (:results (result :scs ,scs))
 318        (:result-types ,el-type)
 319        (:generator 2
 320          (inst add lip object index)
 321          (inst sw value lip (- (* ,offset n-word-bytes) ,lowtag))
 322          (move result value)))
 323      (define-vop (,(symbolicate name "-C"))
 324        ,@(when translate
 325            `((:translate ,translate)))
 326        (:policy :fast-safe)
 327        (:args (object :scs (descriptor-reg))
 328               (value :scs ,scs))
 329        (:info index)
 330        (:arg-types ,type
 331                    (:constant (load/store-index ,n-word-bytes ,(eval lowtag)
 332                                                 ,(eval offset)))
 333                    ,el-type)
 334        (:results (result :scs ,scs))
 335        (:result-types ,el-type)
 336        (:generator 1
 337          (inst sw value object (- (* (+ ,offset index) n-word-bytes) ,lowtag))
 338          (move result value)))))
 339
 340
 341 (defmacro define-partial-reffer (name type size signed offset lowtag scs
 342                                       el-type &optional translate)
 343   (let ((scale (ecase size (:byte 1) (:short 2))))
 344     `(progn
 345        (define-vop (,name)
 346          ,@(when translate
 347              `((:translate ,translate)))
 348          (:policy :fast-safe)
 349          (:args (object :scs (descriptor-reg))
 350                 (index :scs (unsigned-reg)))
 351          (:arg-types ,type positive-fixnum)
 352          (:results (value :scs ,scs))
 353          (:result-types ,el-type)
 354          (:temporary (:scs (interior-reg)) lip)
 355          (:generator 5
 356            (inst addu lip object index)
 357            ,@(when (eq size :short)
 358                '((inst addu lip index)))
 359            (inst ,(ecase size
 360                     (:byte (if signed 'lb 'lbu))
 361                     (:short (if signed 'lh 'lhu)))
 362                  value lip (- (* ,offset n-word-bytes) ,lowtag))
 363            (inst nop)))
 364        (define-vop (,(symbolicate name "-C"))
 365          ,@(when translate
 366              `((:translate ,translate)))
 367          (:policy :fast-safe)
 368          (:args (object :scs (descriptor-reg)))
 369          (:info index)
 370          (:arg-types ,type
 371                      (:constant (load/store-index ,scale
 372                                                   ,(eval lowtag)
 373                                                   ,(eval offset))))
 374          (:results (value :scs ,scs))
 375          (:result-types ,el-type)
 376          (:generator 5
 377            (inst ,(ecase size
 378                     (:byte (if signed 'lb 'lbu))
 379                     (:short (if signed 'lh 'lhu)))
 380                  value object
 381                  (- (+ (* ,offset n-word-bytes) (* index ,scale)) ,lowtag))
 382            (inst nop))))))
 383
 384 (defmacro define-partial-setter (name type size offset lowtag scs el-type
 385                                       &optional translate)
 386   (let ((scale (ecase size (:byte 1) (:short 2))))
 387     `(progn
 388        (define-vop (,name)
 389          ,@(when translate
 390              `((:translate ,translate)))
 391          (:policy :fast-safe)
 392          (:args (object :scs (descriptor-reg))
 393                 (index :scs (unsigned-reg))
 394                 (value :scs ,scs :target result))
 395          (:arg-types ,type positive-fixnum ,el-type)
 396          (:temporary (:scs (interior-reg)) lip)
 397          (:results (result :scs ,scs))
 398          (:result-types ,el-type)
 399          (:generator 5
 400            (inst addu lip object index)
 401            ,@(when (eq size :short)
 402                '((inst addu lip index)))
 403            (inst ,(ecase size (:byte 'sb) (:short 'sh))
 404                  value lip (- (* ,offset n-word-bytes) ,lowtag))
 405            (move result value)))
 406        (define-vop (,(symbolicate name "-C"))
 407          ,@(when translate
 408              `((:translate ,translate)))
 409          (:policy :fast-safe)
 410          (:args (object :scs (descriptor-reg))
 411                 (value :scs ,scs :target result))
 412          (:info index)
 413          (:arg-types ,type
 414                      (:constant (load/store-index ,scale
 415                                                   ,(eval lowtag)
 416                                                   ,(eval offset)))
 417                      ,el-type)
 418          (:results (result :scs ,scs))
 419          (:result-types ,el-type)
 420          (:generator 5
 421            (inst ,(ecase size (:byte 'sb) (:short 'sh))
 422                  value object
 423                  (- (* ,offset n-word-bytes) (* index ,scale) ,lowtag))
 424            (move result value))))))
 425