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))))))
 439
 440
 441 (sb!xc:defmacro with-pinned-objects ((&rest objects) &body body)
 442   "Arrange with the garbage collector that the pages occupied by
 443 OBJECTS will not be moved in memory for the duration of BODY.
 444 Useful for e.g. foreign calls where another thread may trigger
 445 garbage collection.  This is currently implemented by disabling GC"
 446   (declare (ignore objects))            ;should we eval these for side-effect?
 447   `(without-gcing
 448     ,@body))