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