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   (let ((continue (gensym "CONTINUE-LABEL-"))
 232         (error (gensym "ERROR-LABEL-")))
 233     `(let ((,continue (gen-label)))
 234        (emit-label ,continue)
 235        (assemble (*elsewhere*)
 236          (let ((,error (gen-label)))
 237            (emit-label ,error)
 238            (cerror-call ,vop ,continue ,error-code ,@values)
 239            ,error)))))
 240
 241 \f
 242 ;;; PSEUDO-ATOMIC -- 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
 261
 262 \f
 263 ;;;; Memory accessor vop generators
 264
 265 (deftype load/store-index (scale lowtag min-offset
 266                                  &optional (max-offset min-offset))
 267   `(integer ,(- (truncate (+ (ash 1 16)
 268                              (* min-offset n-word-bytes)
 269                              (- lowtag))
 270                           scale))
 271             ,(truncate (- (+ (1- (ash 1 16)) lowtag)
 272                           (* max-offset n-word-bytes))
 273                        scale)))
 274
 275 (defmacro define-full-reffer (name type offset lowtag scs el-type
 276                                    &optional translate)
 277   `(progn
 278      (define-vop (,name)
 279        ,@(when translate
 280            `((:translate ,translate)))
 281        (:policy :fast-safe)
 282        (:args (object :scs (descriptor-reg))
 283               (index :scs (any-reg)))
 284        (:arg-types ,type tagged-num)
 285        (:temporary (:scs (interior-reg)) lip)
 286        (:results (value :scs ,scs))
 287        (:result-types ,el-type)
 288        (:generator 5
 289          (inst add lip object index)
 290          (inst lw value lip (- (* ,offset n-word-bytes) ,lowtag))
 291          (inst nop)))
 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 lw value object (- (* (+ ,offset index) n-word-bytes) ,lowtag))
 305          (inst nop)))))
 306
 307 (defmacro define-full-setter (name type offset lowtag scs el-type
 308                                    &optional translate)
 309   `(progn
 310      (define-vop (,name)
 311        ,@(when translate
 312            `((:translate ,translate)))
 313        (:policy :fast-safe)
 314        (:args (object :scs (descriptor-reg))
 315               (index :scs (any-reg))
 316               (value :scs ,scs :target result))
 317        (:arg-types ,type tagged-num ,el-type)
 318        (:temporary (:scs (interior-reg)) lip)
 319        (:results (result :scs ,scs))
 320        (:result-types ,el-type)
 321        (:generator 2
 322          (inst add lip object index)
 323          (inst sw value lip (- (* ,offset n-word-bytes) ,lowtag))
 324          (move result value)))
 325      (define-vop (,(symbolicate name "-C"))
 326        ,@(when translate
 327            `((:translate ,translate)))
 328        (:policy :fast-safe)
 329        (:args (object :scs (descriptor-reg))
 330               (value :scs ,scs))
 331        (:info index)
 332        (:arg-types ,type
 333                    (:constant (load/store-index ,n-word-bytes ,(eval lowtag)
 334                                                 ,(eval offset)))
 335                    ,el-type)
 336        (:results (result :scs ,scs))
 337        (:result-types ,el-type)
 338        (:generator 1
 339          (inst sw value object (- (* (+ ,offset index) n-word-bytes) ,lowtag))
 340          (move result value)))))
 341
 342
 343 (defmacro define-partial-reffer (name type size signed offset lowtag scs
 344                                       el-type &optional translate)
 345   (let ((scale (ecase size (:byte 1) (:short 2))))
 346     `(progn
 347        (define-vop (,name)
 348          ,@(when translate
 349              `((:translate ,translate)))
 350          (:policy :fast-safe)
 351          (:args (object :scs (descriptor-reg))
 352                 (index :scs (unsigned-reg)))
 353          (:arg-types ,type positive-fixnum)
 354          (:results (value :scs ,scs))
 355          (:result-types ,el-type)
 356          (:temporary (:scs (interior-reg)) lip)
 357          (:generator 5
 358            (inst addu lip object index)
 359            ,@(when (eq size :short)
 360                '((inst addu lip index)))
 361            (inst ,(ecase size
 362                     (:byte (if signed 'lb 'lbu))
 363                     (:short (if signed 'lh 'lhu)))
 364                  value lip (- (* ,offset n-word-bytes) ,lowtag))
 365            (inst nop)))
 366        (define-vop (,(symbolicate name "-C"))
 367          ,@(when translate
 368              `((:translate ,translate)))
 369          (:policy :fast-safe)
 370          (:args (object :scs (descriptor-reg)))
 371          (:info index)
 372          (:arg-types ,type
 373                      (:constant (load/store-index ,scale
 374                                                   ,(eval lowtag)
 375                                                   ,(eval offset))))
 376          (:results (value :scs ,scs))
 377          (:result-types ,el-type)
 378          (:generator 5
 379            (inst ,(ecase size
 380                     (:byte (if signed 'lb 'lbu))
 381                     (:short (if signed 'lh 'lhu)))
 382                  value object
 383                  (- (+ (* ,offset n-word-bytes) (* index ,scale)) ,lowtag))
 384            (inst nop))))))
 385
 386 (defmacro define-partial-setter (name type size offset lowtag scs el-type
 387                                       &optional translate)
 388   (let ((scale (ecase size (:byte 1) (:short 2))))
 389     `(progn
 390        (define-vop (,name)
 391          ,@(when translate
 392              `((:translate ,translate)))
 393          (:policy :fast-safe)
 394          (:args (object :scs (descriptor-reg))
 395                 (index :scs (unsigned-reg))
 396                 (value :scs ,scs :target result))
 397          (:arg-types ,type positive-fixnum ,el-type)
 398          (:temporary (:scs (interior-reg)) lip)
 399          (:results (result :scs ,scs))
 400          (:result-types ,el-type)
 401          (:generator 5
 402            (inst addu lip object index)
 403            ,@(when (eq size :short)
 404                '((inst addu lip index)))
 405            (inst ,(ecase size (:byte 'sb) (:short 'sh))
 406                  value lip (- (* ,offset n-word-bytes) ,lowtag))
 407            (move result value)))
 408        (define-vop (,(symbolicate name "-C"))
 409          ,@(when translate
 410              `((:translate ,translate)))
 411          (:policy :fast-safe)
 412          (:args (object :scs (descriptor-reg))
 413                 (value :scs ,scs :target result))
 414          (:info index)
 415          (:arg-types ,type
 416                      (:constant (load/store-index ,scale
 417                                                   ,(eval lowtag)
 418                                                   ,(eval offset)))
 419                      ,el-type)
 420          (:results (result :scs ,scs))
 421          (:result-types ,el-type)
 422          (:generator 5
 423            (inst ,(ecase size (:byte 'sb) (:short 'sh))
 424                  value object
 425                  (- (* ,offset n-word-bytes) (* index ,scale) ,lowtag))
 426            (move result value))))))
 427