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