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 (location= ,n-dst ,n-src)
  32          (when ,always-emit-code-p
  33            (inst nop))
  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 t)))
  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 t)
  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 NL4-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   (unless body
 146     (bug "empty &body in WITH-FIXED-ALLOCATION"))
 147   (once-only ((result-tn result-tn) (temp-tn temp-tn) (size size))
 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 \f
 155 ;;;; Three Way Comparison
 156 (defun three-way-comparison (x y condition flavor not-p target temp)
 157   (ecase condition
 158     (:eq
 159      (if not-p
 160          (inst bne x y target)
 161          (inst beq x y target)))
 162     (:lt
 163      (ecase flavor
 164        (:unsigned
 165         (inst sltu temp x y))
 166        (:signed
 167         (inst slt temp x y)))
 168      (if not-p
 169          (inst beq temp zero-tn target)
 170          (inst bne temp zero-tn target)))
 171     (:gt
 172      (ecase flavor
 173        (:unsigned
 174         (inst sltu temp y x))
 175        (:signed
 176         (inst slt temp y x)))
 177      (if not-p
 178          (inst beq temp zero-tn target)
 179          (inst bne temp zero-tn target))))
 180   (inst nop))
 181
 182
 183 \f
 184 ;;;; Error Code
 185 (eval-when (compile load eval)
 186   (defun emit-error-break (vop kind code values)
 187     (let ((vector (gensym)))
 188       `((let ((vop ,vop))
 189           (when vop
 190             (note-this-location vop :internal-error)))
 191         (inst break ,kind)
 192         (with-adjustable-vector (,vector)
 193           (write-var-integer (error-number-or-lose ',code) ,vector)
 194           ,@(mapcar #'(lambda (tn)
 195                         `(let ((tn ,tn))
 196                            (write-var-integer (make-sc-offset (sc-number
 197                                                                (tn-sc tn))
 198                                                               (tn-offset tn))
 199                                               ,vector)))
 200                     values)
 201           (inst byte (length ,vector))
 202           (dotimes (i (length ,vector))
 203             (inst byte (aref ,vector i))))
 204         (align word-shift)))))
 205
 206 (defmacro error-call (vop error-code &rest values)
 207   "Cause an error.  ERROR-CODE is the error to cause."
 208   (cons 'progn
 209         (emit-error-break vop error-trap error-code values)))
 210
 211
 212 (defmacro cerror-call (vop label error-code &rest values)
 213   "Cause a continuable error.  If the error is continued, execution resumes at
 214   LABEL."
 215   `(progn
 216      (inst b ,label)
 217      ,@(emit-error-break vop cerror-trap error-code values)))
 218
 219 (defmacro generate-error-code (vop error-code &rest values)
 220   "Generate-Error-Code Error-code Value*
 221   Emit code for an error with the specified Error-Code and context Values."
 222   `(assemble (*elsewhere*)
 223      (let ((start-lab (gen-label)))
 224        (emit-label start-lab)
 225        (error-call ,vop ,error-code ,@values)
 226        start-lab)))
 227
 228 (defmacro generate-cerror-code (vop error-code &rest values)
 229   "Generate-CError-Code Error-code Value*
 230   Emit code for a continuable error with the specified Error-Code and
 231   context Values.  If the error is continued, execution resumes after
 232   the GENERATE-CERROR-CODE form."
 233   (with-unique-names (continue error)
 234     `(let ((,continue (gen-label)))
 235        (emit-label ,continue)
 236        (assemble (*elsewhere*)
 237          (let ((,error (gen-label)))
 238            (emit-label ,error)
 239            (cerror-call ,vop ,continue ,error-code ,@values)
 240            ,error)))))
 241 \f
 242 ;;;; PSEUDO-ATOMIC
 243
 244 ;;; handy macro for making sequences look atomic
 245 (defmacro pseudo-atomic ((flag-tn &key (extra 0)) &rest forms)
 246   `(progn
 247      (aver (= (tn-offset ,flag-tn) nl4-offset))
 248      (aver (not (minusp ,extra)))
 249      (without-scheduling ()
 250        (inst li ,flag-tn ,extra)
 251        (inst addu alloc-tn 1))
 252      ,@forms
 253      (without-scheduling ()
 254        (let ((label (gen-label)))
 255          (inst nop)
 256          (inst nop)
 257          (inst nop)
 258          (inst bgez ,flag-tn label)
 259          (inst addu alloc-tn (1- ,extra))
 260          (inst break 16)
 261          (emit-label label)))))
 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 4
 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 4
 423            (inst ,(ecase size (:byte 'sb) (:short 'sh))
 424                  value object
 425                  (- (+ (* ,offset n-word-bytes) (* index ,scale)) ,lowtag))
 426            (move result value))))))
 427
 428
 429 (defmacro sb!sys::with-pinned-objects ((&rest objects) &body body)
 430   "Arrange with the garbage collector that the pages occupied by
 431 OBJECTS will not be moved in memory for the duration of BODY.
 432 Useful for e.g. foreign calls where another thread may trigger
 433 garbage collection.  This is currently implemented by disabling GC"
 434   (declare (ignore objects))            ;should we eval these for side-effect?
 435   `(without-gcing
 436     ,@body))