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 (1- n-word-bytes)))))))
  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      (emit-alignment 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
 141                                   size dynamic-extent-p
 142                                   &key (lowtag other-pointer-lowtag))
 143                                  &body body)
 144   "Do stuff to allocate an other-pointer object of fixed Size with a single
 145 word header having the specified Type-Code.  The result is placed in
 146 Result-TN, Flag-Tn must be wired to NL4-OFFSET, and Temp-TN is a non-
 147 descriptor temp (which may be randomly used by the body.)  The body is
 148 placed inside the PSEUDO-ATOMIC, and presumably initializes the object."
 149   (unless body
 150     (bug "empty &body in WITH-FIXED-ALLOCATION"))
 151   (once-only ((result-tn result-tn) (flag-tn flag-tn) (temp-tn temp-tn)
 152               (type-code type-code) (size size)
 153               (dynamic-extent-p dynamic-extent-p)
 154               (lowtag lowtag))
 155     `(if ,dynamic-extent-p
 156          (pseudo-atomic (,flag-tn)
 157            (align-csp ,temp-tn)
 158            (inst or ,result-tn csp-tn ,lowtag)
 159            (inst li ,temp-tn (logior (ash (1- ,size) n-widetag-bits) ,type-code))
 160            (inst addu csp-tn (pad-data-block ,size))
 161            (storew ,temp-tn ,result-tn 0 ,lowtag)
 162            ,@body)
 163          (pseudo-atomic (,flag-tn :extra (pad-data-block ,size))
 164            ;; The pseudo-atomic bit in alloc-tn is set.  If the lowtag also
 165            ;; has a 1 bit in the same position, we're all set.  Otherwise,
 166            ;; we need to subtract the pseudo-atomic bit.
 167            (inst or ,result-tn alloc-tn ,lowtag)
 168            (unless (logbitp 0 ,lowtag) (inst subu ,result-tn 1))
 169            (inst li ,temp-tn (logior (ash (1- ,size) n-widetag-bits) ,type-code))
 170            (storew ,temp-tn ,result-tn 0 ,lowtag)
 171            ,@body))))
 172
 173 (defun align-csp (temp)
 174   ;; is used for stack allocation of dynamic-extent objects
 175   (let ((aligned (gen-label)))
 176     (inst and temp csp-tn lowtag-mask)
 177     (inst beq temp aligned)
 178     (inst nop)
 179     (inst addu csp-tn n-word-bytes)
 180     (storew zero-tn csp-tn -1)
 181     (emit-label aligned)))
 182
 183 \f
 184 ;;;; Three Way Comparison
 185 (defun three-way-comparison (x y condition flavor not-p target temp)
 186   (ecase condition
 187     (:eq
 188      (if not-p
 189          (inst bne x y target)
 190          (inst beq x y target)))
 191     (:lt
 192      (ecase flavor
 193        (:unsigned
 194         (inst sltu temp x y))
 195        (:signed
 196         (inst slt temp x y)))
 197      (if not-p
 198          (inst beq temp target)
 199          (inst bne temp target)))
 200     (:gt
 201      (ecase flavor
 202        (:unsigned
 203         (inst sltu temp y x))
 204        (:signed
 205         (inst slt temp y x)))
 206      (if not-p
 207          (inst beq temp target)
 208          (inst bne temp target))))
 209   (inst nop))
 210
 211
 212 \f
 213 ;;;; Error Code
 214 (defun emit-error-break (vop kind code values)
 215   (assemble ()
 216     (when vop
 217       (note-this-location vop :internal-error))
 218     (inst break 0 kind)
 219     (inst byte code)
 220     (encode-internal-error-args values)
 221     (emit-alignment word-shift)))
 222
 223 (defun error-call (vop error-code &rest values)
 224   "Cause an error.  ERROR-CODE is the error to cause."
 225   (emit-error-break vop error-trap (error-number-or-lose error-code) values))
 226
 227
 228 (defun cerror-call (vop label error-code &rest values)
 229   "Cause a continuable error.  If the error is continued, execution resumes at
 230   LABEL."
 231   (assemble ()
 232     (without-scheduling ()
 233       (inst b label)
 234       (emit-error-break vop cerror-trap (error-number-or-lose error-code) values))))
 235
 236 (defun generate-error-code (vop error-code &rest values)
 237   "Generate-Error-Code Error-code Value*
 238   Emit code for an error with the specified Error-Code and context Values."
 239   (assemble (*elsewhere*)
 240     (let ((start-lab (gen-label)))
 241       (emit-label start-lab)
 242       (apply #'error-call vop error-code values)
 243       start-lab)))
 244
 245 (defun generate-cerror-code (vop error-code &rest values)
 246   "Generate-CError-Code Error-code Value*
 247   Emit code for a continuable error with the specified Error-Code and
 248   context Values.  If the error is continued, execution resumes after
 249   the GENERATE-CERROR-CODE form."
 250   (assemble ()
 251     (let ((continue (gen-label)))
 252       (emit-label continue)
 253       (assemble (*elsewhere*)
 254         (let ((error (gen-label)))
 255           (emit-label error)
 256           (apply #'cerror-call vop continue error-code values)
 257           error)))))
 258 \f
 259 ;;;; PSEUDO-ATOMIC
 260
 261 ;;; handy macro for making sequences look atomic
 262 (defmacro pseudo-atomic ((flag-tn &key (extra 0)) &rest forms)
 263   `(progn
 264      (aver (= (tn-offset ,flag-tn) nl4-offset))
 265      (aver (not (minusp ,extra)))
 266      (without-scheduling ()
 267        (inst li ,flag-tn ,extra)
 268        (inst addu alloc-tn 1))
 269      ,@forms
 270      (without-scheduling ()
 271        (let ((label (gen-label)))
 272          (inst bgez ,flag-tn label)
 273          (inst addu alloc-tn (1- ,extra))
 274          (inst break 0 pending-interrupt-trap)
 275          (emit-label label)))))
 276 \f
 277 ;;;; memory accessor vop generators
 278
 279 (deftype load/store-index (scale lowtag min-offset
 280                                  &optional (max-offset min-offset))
 281   `(integer ,(- (truncate (+ (ash 1 16)
 282                              (* min-offset n-word-bytes)
 283                              (- lowtag))
 284                           scale))
 285             ,(truncate (- (+ (1- (ash 1 16)) lowtag)
 286                           (* max-offset n-word-bytes))
 287                        scale)))
 288
 289 (defmacro define-full-reffer (name type offset lowtag scs el-type
 290                                    &optional translate)
 291   `(progn
 292      (define-vop (,name)
 293        ,@(when translate
 294            `((:translate ,translate)))
 295        (:policy :fast-safe)
 296        (:args (object :scs (descriptor-reg))
 297               (index :scs (any-reg)))
 298        (:arg-types ,type tagged-num)
 299        (:temporary (:scs (interior-reg)) lip)
 300        (:results (value :scs ,scs))
 301        (:result-types ,el-type)
 302        (:generator 5
 303          (inst addu lip object index)
 304          (loadw value lip ,offset ,lowtag)))
 305      (define-vop (,(symbolicate name "-C"))
 306        ,@(when translate
 307            `((:translate ,translate)))
 308        (:policy :fast-safe)
 309        (:args (object :scs (descriptor-reg)))
 310        (:info index)
 311        (:arg-types ,type
 312                    (:constant (load/store-index ,n-word-bytes ,(eval lowtag)
 313                                                 ,(eval offset))))
 314        (:results (value :scs ,scs))
 315        (:result-types ,el-type)
 316        (:generator 4
 317          (loadw value object (+ ,offset index) ,lowtag)))))
 318
 319 (defmacro define-full-setter (name type offset lowtag scs el-type
 320                                    &optional translate)
 321   `(progn
 322      (define-vop (,name)
 323        ,@(when translate
 324            `((:translate ,translate)))
 325        (:policy :fast-safe)
 326        (:args (object :scs (descriptor-reg))
 327               (index :scs (any-reg))
 328               (value :scs ,scs :target result))
 329        (:arg-types ,type tagged-num ,el-type)
 330        (:temporary (:scs (interior-reg)) lip)
 331        (:results (result :scs ,scs))
 332        (:result-types ,el-type)
 333        (:generator 2
 334          (inst addu lip object index)
 335          (storew value lip ,offset ,lowtag)
 336          (move result value)))
 337      (define-vop (,(symbolicate name "-C"))
 338        ,@(when translate
 339            `((:translate ,translate)))
 340        (:policy :fast-safe)
 341        (:args (object :scs (descriptor-reg))
 342               (value :scs ,scs))
 343        (:info index)
 344        (:arg-types ,type
 345                    (:constant (load/store-index ,n-word-bytes ,(eval lowtag)
 346                                                 ,(eval offset)))
 347                    ,el-type)
 348        (:results (result :scs ,scs))
 349        (:result-types ,el-type)
 350        (:generator 1
 351          (storew value object (+ ,offset index) ,lowtag)
 352          (move result value)))))
 353
 354
 355 (defmacro define-partial-reffer (name type size signed offset lowtag scs
 356                                       el-type &optional translate)
 357   (let ((scale (ecase size (:byte 1) (:short 2))))
 358     `(progn
 359        (define-vop (,name)
 360          ,@(when translate
 361              `((:translate ,translate)))
 362          (:policy :fast-safe)
 363          (:args (object :scs (descriptor-reg))
 364                 (index :scs (unsigned-reg)))
 365          (:arg-types ,type positive-fixnum)
 366          (:results (value :scs ,scs))
 367          (:result-types ,el-type)
 368          (:temporary (:scs (interior-reg)) lip)
 369          (:generator 5
 370            (inst addu lip object index)
 371            ,@(when (eq size :short)
 372                '((inst addu lip index)))
 373            (inst ,(ecase size
 374                     (:byte (if signed 'lb 'lbu))
 375                     (:short (if signed 'lh 'lhu)))
 376                  value lip (- (* ,offset n-word-bytes) ,lowtag))
 377            (inst nop)))
 378        (define-vop (,(symbolicate name "-C"))
 379          ,@(when translate
 380              `((:translate ,translate)))
 381          (:policy :fast-safe)
 382          (:args (object :scs (descriptor-reg)))
 383          (:info index)
 384          (:arg-types ,type
 385                      (:constant (load/store-index ,scale
 386                                                   ,(eval lowtag)
 387                                                   ,(eval offset))))
 388          (:results (value :scs ,scs))
 389          (:result-types ,el-type)
 390          (:generator 4
 391            (inst ,(ecase size
 392                     (:byte (if signed 'lb 'lbu))
 393                     (:short (if signed 'lh 'lhu)))
 394                  value object
 395                  (- (+ (* ,offset n-word-bytes) (* index ,scale)) ,lowtag))
 396            (inst nop))))))
 397
 398 (defmacro define-partial-setter (name type size offset lowtag scs el-type
 399                                       &optional translate)
 400   (let ((scale (ecase size (:byte 1) (:short 2))))
 401     `(progn
 402        (define-vop (,name)
 403          ,@(when translate
 404              `((:translate ,translate)))
 405          (:policy :fast-safe)
 406          (:args (object :scs (descriptor-reg))
 407                 (index :scs (unsigned-reg))
 408                 (value :scs ,scs :target result))
 409          (:arg-types ,type positive-fixnum ,el-type)
 410          (:temporary (:scs (interior-reg)) lip)
 411          (:results (result :scs ,scs))
 412          (:result-types ,el-type)
 413          (:generator 5
 414            (inst addu lip object index)
 415            ,@(when (eq size :short)
 416                '((inst addu lip index)))
 417            (inst ,(ecase size (:byte 'sb) (:short 'sh))
 418                  value lip (- (* ,offset n-word-bytes) ,lowtag))
 419            (move result value)))
 420        (define-vop (,(symbolicate name "-C"))
 421          ,@(when translate
 422              `((:translate ,translate)))
 423          (:policy :fast-safe)
 424          (:args (object :scs (descriptor-reg))
 425                 (value :scs ,scs :target result))
 426          (:info index)
 427          (:arg-types ,type
 428                      (:constant (load/store-index ,scale
 429                                                   ,(eval lowtag)
 430                                                   ,(eval offset)))
 431                      ,el-type)
 432          (:results (result :scs ,scs))
 433          (:result-types ,el-type)
 434          (:generator 4
 435            (inst ,(ecase size (:byte 'sb) (:short 'sh))
 436                  value object
 437                  (- (+ (* ,offset n-word-bytes) (* index ,scale)) ,lowtag))
 438            (move result value))))))