src/compiler/mips/macros.lisp

   1 (in-package "SB!VM")
   2
   3 ;;; Handy macro for defining top-level forms that depend on the compile
   4 ;;; environment.
   5
   6 (defmacro expand (expr)
   7   (let ((gensym (gensym)))
   8     `(macrolet
   9          ((,gensym ()
  10             ,expr))
  11        (,gensym))))
  12
  13 \f
  14 ;;; Instruction-like macros.
  15
  16 (defmacro move (dst src &optional (always-emit-code-p nil))
  17   "Move SRC into DST (unless they are location= and ALWAYS-EMIT-CODE-P
  18   is nil)."
  19   (once-only ((n-dst dst)
  20               (n-src src))
  21     (if always-emit-code-p
  22         `(inst move ,n-dst ,n-src)
  23         `(unless (location= ,n-dst ,n-src)
  24            (inst move ,n-dst ,n-src)))))
  25
  26 (defmacro def-mem-op (op inst shift load)
  27   `(defmacro ,op (object base &optional (offset 0) (lowtag 0))
  28      `(progn
  29         (inst ,',inst ,object ,base (- (ash ,offset ,,shift) ,lowtag))
  30         ,,@(when load '('(inst nop))))))
  31 ;;;
  32 (def-mem-op loadw lw word-shift t)
  33 (def-mem-op storew sw word-shift nil)
  34
  35 (defmacro load-symbol (reg symbol)
  36   `(inst addu ,reg null-tn (static-symbol-offset ,symbol)))
  37
  38 (defmacro load-symbol-value (reg symbol)
  39   `(progn
  40      (inst lw ,reg null-tn
  41            (+ (static-symbol-offset ',symbol)
  42               (ash symbol-value-slot word-shift)
  43               (- other-pointer-lowtag)))
  44      (inst nop)))
  45
  46 (defmacro store-symbol-value (reg symbol)
  47   `(inst sw ,reg null-tn
  48          (+ (static-symbol-offset ',symbol)
  49             (ash symbol-value-slot word-shift)
  50             (- other-pointer-lowtag))))
  51
  52 (defmacro load-type (target source &optional (offset 0))
  53   "Loads the type bits of a pointer into target independent of
  54   byte-ordering issues."
  55   (once-only ((n-target target)
  56               (n-source source)
  57               (n-offset offset))
  58     (ecase *backend-byte-order*
  59       (:little-endian
  60        `(inst lbu ,n-target ,n-source ,n-offset ))
  61       (:big-endian
  62        `(inst lbu ,n-target ,n-source (+ ,n-offset 3))))))
  63
  64
  65 ;;; Macros to handle the fact that we cannot use the machine native call and
  66 ;;; return instructions.
  67
  68 (defmacro lisp-jump (function lip)
  69   "Jump to the lisp function FUNCTION.  LIP is an interior-reg temporary."
  70   `(progn
  71      (inst addu ,lip ,function (- (ash simple-fun-code-offset word-shift)
  72                                    fun-pointer-lowtag))
  73      (inst j ,lip)
  74      (move code-tn ,function)))
  75
  76 (defmacro lisp-return (return-pc lip &key (offset 0) (frob-code t))
  77   "Return to RETURN-PC.  LIP is an interior-reg temporary."
  78   `(progn
  79      (inst addu ,lip ,return-pc
  80            (- (* (1+ ,offset) n-word-bytes) other-pointer-lowtag))
  81      (inst j ,lip)
  82      ,(if frob-code
  83           `(move code-tn ,return-pc)
  84           '(inst nop))))
  85
  86
  87 (defmacro emit-return-pc (label)
  88   "Emit a return-pc header word.  LABEL is the label to use for this return-pc."
  89   `(progn
  90      (align n-lowtag-bits)
  91      (emit-label ,label)
  92      (inst lra-header-word)))
  93
  94
  95 \f
  96 ;;;; Stack TN's
  97
  98 ;;; Load-Stack-TN, Store-Stack-TN  --  Interface
  99 ;;;
 100 ;;;    Move a stack TN to a register and vice-versa.
 101 ;;;
 102 (defmacro load-stack-tn (reg stack)
 103   `(let ((reg ,reg)
 104          (stack ,stack))
 105      (let ((offset (tn-offset stack)))
 106        (sc-case stack
 107          ((control-stack)
 108           (loadw reg cfp-tn offset))))))
 109
 110 (defmacro store-stack-tn (stack reg)
 111   `(let ((stack ,stack)
 112          (reg ,reg))
 113      (let ((offset (tn-offset stack)))
 114        (sc-case stack
 115          ((control-stack)
 116           (storew reg cfp-tn offset))))))
 117
 118
 119 ;;; MAYBE-LOAD-STACK-TN  --  Interface
 120 ;;;
 121 (defmacro maybe-load-stack-tn (reg reg-or-stack)
 122   "Move the TN Reg-Or-Stack into Reg if it isn't already there."
 123   (once-only ((n-reg reg)
 124               (n-stack reg-or-stack))
 125     `(sc-case ,n-reg
 126        ((any-reg descriptor-reg)
 127         (sc-case ,n-stack
 128           ((any-reg descriptor-reg)
 129            (move ,n-reg ,n-stack))
 130           ((control-stack)
 131            (loadw ,n-reg cfp-tn (tn-offset ,n-stack))))))))
 132
 133 \f
 134 ;;;; Storage allocation:
 135
 136 (defmacro with-fixed-allocation ((result-tn flag-tn temp-tn type-code size)
 137                                  &body body)
 138   "Do stuff to allocate an other-pointer object of fixed Size with a single
 139    word header having the specified Type-Code.  The result is placed in
 140    Result-TN, Flag-Tn must be wired to NL3-OFFSET, and Temp-TN is a non-
 141    descriptor temp (which may be randomly used by the body.)  The body is
 142    placed inside the PSEUDO-ATOMIC, and presumably initializes the object."
 143   `(pseudo-atomic (,flag-tn :extra (pad-data-block ,size))
 144      (inst or ,result-tn alloc-tn other-pointer-lowtag)
 145      (inst li ,temp-tn (logior (ash (1- ,size) n-widetag-bits) ,type-code))
 146      (storew ,temp-tn ,result-tn 0 other-pointer-lowtag)
 147      ,@body))
 148
 149
 150 \f
 151 ;;;; Three Way Comparison
 152
 153 (defun three-way-comparison (x y condition flavor not-p target temp)
 154   (ecase condition
 155     (:eq
 156      (if not-p
 157          (inst bne x y target)
 158          (inst beq x y target)))
 159     (:lt
 160      (ecase flavor
 161        (:unsigned
 162         (inst sltu temp x y))
 163        (:signed
 164         (inst slt temp x y)))
 165      (if not-p
 166          (inst beq temp zero-tn target)
 167          (inst bne temp zero-tn target)))
 168     (:gt
 169      (ecase flavor
 170        (:unsigned
 171         (inst sltu temp y x))
 172        (:signed
 173         (inst slt temp y x)))
 174      (if not-p
 175          (inst beq temp zero-tn target)
 176          (inst bne temp zero-tn target))))
 177   (inst nop))
 178
 179
 180 \f
 181 ;;;; Error Code
 182
 183
 184 (defvar *adjustable-vectors* nil)
 185
 186 (defmacro with-adjustable-vector ((var) &rest body)
 187   `(let ((,var (or (pop *adjustable-vectors*)
 188                    (make-array 16
 189                                :element-type '(unsigned-byte 8)
 190                                :fill-pointer 0
 191                                :adjustable t))))
 192      (setf (fill-pointer ,var) 0)
 193      (unwind-protect
 194          (progn
 195            ,@body)
 196        (push ,var *adjustable-vectors*))))
 197
 198 (eval-when (compile load eval)
 199   (defun emit-error-break (vop kind code values)
 200     (let ((vector (gensym)))
 201       `((let ((vop ,vop))
 202           (when vop
 203             (note-this-location vop :internal-error)))
 204         (inst break ,kind)
 205         (with-adjustable-vector (,vector)
 206           (write-var-integer (error-number-or-lose ',code) ,vector)
 207           ,@(mapcar #'(lambda (tn)
 208                         `(let ((tn ,tn))
 209                            (write-var-integer (make-sc-offset (sc-number
 210                                                                (tn-sc tn))
 211                                                               (tn-offset tn))
 212                                               ,vector)))
 213                     values)
 214           (inst byte (length ,vector))
 215           (dotimes (i (length ,vector))
 216             (inst byte (aref ,vector i))))
 217         (align word-shift)))))
 218
 219 (defmacro error-call (vop error-code &rest values)
 220   "Cause an error.  ERROR-CODE is the error to cause."
 221   (cons 'progn
 222         (emit-error-break vop error-trap error-code values)))
 223
 224
 225 (defmacro cerror-call (vop label error-code &rest values)
 226   "Cause a continuable error.  If the error is continued, execution resumes at
 227   LABEL."
 228   `(progn
 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   (let ((continue (gensym "CONTINUE-LABEL-"))
 247         (error (gensym "ERROR-LABEL-")))
 248     `(let ((,continue (gen-label)))
 249        (emit-label ,continue)
 250        (assemble (*elsewhere*)
 251          (let ((,error (gen-label)))
 252            (emit-label ,error)
 253            (cerror-call ,vop ,continue ,error-code ,@values)
 254            ,error)))))
 255
 256 \f
 257 ;;; PSEUDO-ATOMIC -- 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 nop)
 269          (inst nop)
 270          (inst nop)
 271          (inst bgez ,flag-tn label)
 272          (inst addu alloc-tn (1- ,extra))
 273          (inst break 16)
 274          (emit-label label)))))
 275
 276
 277 \f
 278 ;;;; Memory accessor vop generators
 279
 280 (deftype load/store-index (scale lowtag min-offset
 281                                  &optional (max-offset min-offset))
 282   `(integer ,(- (truncate (+ (ash 1 16)
 283                              (* min-offset n-word-bytes)
 284                              (- lowtag))
 285                           scale))
 286             ,(truncate (- (+ (1- (ash 1 16)) lowtag)
 287                           (* max-offset n-word-bytes))
 288                        scale)))
 289
 290 (defmacro define-full-reffer (name type offset lowtag scs el-type
 291                                    &optional translate)
 292   `(progn
 293      (define-vop (,name)
 294        ,@(when translate
 295            `((:translate ,translate)))
 296        (:policy :fast-safe)
 297        (:args (object :scs (descriptor-reg))
 298               (index :scs (any-reg)))
 299        (:arg-types ,type tagged-num)
 300        (:temporary (:scs (interior-reg)) lip)
 301        (:results (value :scs ,scs))
 302        (:result-types ,el-type)
 303        (:generator 5
 304          (inst add lip object index)
 305          (inst lw value lip (- (* ,offset n-word-bytes) ,lowtag))
 306          (inst nop)))
 307      (define-vop (,(symbolicate name "-C"))
 308        ,@(when translate
 309            `((:translate ,translate)))
 310        (:policy :fast-safe)
 311        (:args (object :scs (descriptor-reg)))
 312        (:info index)
 313        (:arg-types ,type
 314                    (:constant (load/store-index ,n-word-bytes ,(eval lowtag)
 315                                                 ,(eval offset))))
 316        (:results (value :scs ,scs))
 317        (:result-types ,el-type)
 318        (:generator 4
 319          (inst lw value object (- (* (+ ,offset index) n-word-bytes) ,lowtag))
 320          (inst nop)))))
 321
 322 (defmacro define-full-setter (name type offset lowtag scs el-type
 323                                    &optional translate)
 324   `(progn
 325      (define-vop (,name)
 326        ,@(when translate
 327            `((:translate ,translate)))
 328        (:policy :fast-safe)
 329        (:args (object :scs (descriptor-reg))
 330               (index :scs (any-reg))
 331               (value :scs ,scs :target result))
 332        (:arg-types ,type tagged-num ,el-type)
 333        (:temporary (:scs (interior-reg)) lip)
 334        (:results (result :scs ,scs))
 335        (:result-types ,el-type)
 336        (:generator 2
 337          (inst add lip object index)
 338          (inst sw value lip (- (* ,offset n-word-bytes) ,lowtag))
 339          (move result value)))
 340      (define-vop (,(symbolicate name "-C"))
 341        ,@(when translate
 342            `((:translate ,translate)))
 343        (:policy :fast-safe)
 344        (:args (object :scs (descriptor-reg))
 345               (value :scs ,scs))
 346        (:info index)
 347        (:arg-types ,type
 348                    (:constant (load/store-index ,n-word-bytes ,(eval lowtag)
 349                                                 ,(eval offset)))
 350                    ,el-type)
 351        (:results (result :scs ,scs))
 352        (:result-types ,el-type)
 353        (:generator 1
 354          (inst sw value object (- (* (+ ,offset index) n-word-bytes) ,lowtag))
 355          (move result value)))))
 356
 357
 358 (defmacro define-partial-reffer (name type size signed offset lowtag scs
 359                                       el-type &optional translate)
 360   (let ((scale (ecase size (:byte 1) (:short 2))))
 361     `(progn
 362        (define-vop (,name)
 363          ,@(when translate
 364              `((:translate ,translate)))
 365          (:policy :fast-safe)
 366          (:args (object :scs (descriptor-reg))
 367                 (index :scs (unsigned-reg)))
 368          (:arg-types ,type positive-fixnum)
 369          (:results (value :scs ,scs))
 370          (:result-types ,el-type)
 371          (:temporary (:scs (interior-reg)) lip)
 372          (:generator 5
 373            (inst addu lip object index)
 374            ,@(when (eq size :short)
 375                '((inst addu lip index)))
 376            (inst ,(ecase size
 377                     (:byte (if signed 'lb 'lbu))
 378                     (:short (if signed 'lh 'lhu)))
 379                  value lip (- (* ,offset n-word-bytes) ,lowtag))
 380            (inst nop)))
 381        (define-vop (,(symbolicate name "-C"))
 382          ,@(when translate
 383              `((:translate ,translate)))
 384          (:policy :fast-safe)
 385          (:args (object :scs (descriptor-reg)))
 386          (:info index)
 387          (:arg-types ,type
 388                      (:constant (load/store-index ,scale
 389                                                   ,(eval lowtag)
 390                                                   ,(eval offset))))
 391          (:results (value :scs ,scs))
 392          (:result-types ,el-type)
 393          (:generator 5
 394            (inst ,(ecase size
 395                     (:byte (if signed 'lb 'lbu))
 396                     (:short (if signed 'lh 'lhu)))
 397                  value object
 398                  (- (+ (* ,offset n-word-bytes) (* index ,scale)) ,lowtag))
 399            (inst nop))))))
 400
 401 (defmacro define-partial-setter (name type size offset lowtag scs el-type
 402                                       &optional translate)
 403   (let ((scale (ecase size (:byte 1) (:short 2))))
 404     `(progn
 405        (define-vop (,name)
 406          ,@(when translate
 407              `((:translate ,translate)))
 408          (:policy :fast-safe)
 409          (:args (object :scs (descriptor-reg))
 410                 (index :scs (unsigned-reg))
 411                 (value :scs ,scs :target result))
 412          (:arg-types ,type positive-fixnum ,el-type)
 413          (:temporary (:scs (interior-reg)) lip)
 414          (:results (result :scs ,scs))
 415          (:result-types ,el-type)
 416          (:generator 5
 417            (inst addu lip object index)
 418            ,@(when (eq size :short)
 419                '((inst addu lip index)))
 420            (inst ,(ecase size (:byte 'sb) (:short 'sh))
 421                  value lip (- (* ,offset n-word-bytes) ,lowtag))
 422            (move result value)))
 423        (define-vop (,(symbolicate name "-C"))
 424          ,@(when translate
 425              `((:translate ,translate)))
 426          (:policy :fast-safe)
 427          (:args (object :scs (descriptor-reg))
 428                 (value :scs ,scs :target result))
 429          (:info index)
 430          (:arg-types ,type
 431                      (:constant (load/store-index ,scale
 432                                                   ,(eval lowtag)
 433                                                   ,(eval offset)))
 434                      ,el-type)
 435          (:results (result :scs ,scs))
 436          (:result-types ,el-type)
 437          (:generator 5
 438            (inst ,(ecase size (:byte 'sb) (:short 'sh))
 439                  value object
 440                  (- (* ,offset n-word-bytes) (* index ,scale) ,lowtag))
 441            (move result value))))))
 442