src/compiler/sparc/macros.lisp

   1 ;;;; various useful macros for generating Sparc 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
  12 (in-package "SB!VM")
  13 \f
  14 ;;; Instruction-like macros.
  15
  16 (defmacro move (dst src)
  17   "Move SRC into DST unless they are location=."
  18   (once-only ((n-dst dst)
  19               (n-src src))
  20     `(unless (location= ,n-dst ,n-src)
  21        (inst move ,n-dst ,n-src))))
  22
  23 (macrolet
  24     ((frob (op inst shift)
  25        `(defmacro ,op (object base &optional (offset 0) (lowtag 0))
  26           `(inst ,',inst ,object ,base (- (ash ,offset ,,shift) ,lowtag)))))
  27   (frob loadw ld word-shift)
  28   (frob storew st word-shift))
  29
  30 (defmacro load-symbol (reg symbol)
  31   `(inst add ,reg null-tn (static-symbol-offset ,symbol)))
  32
  33 (macrolet
  34     ((frob (slot)
  35        (let ((loader (intern (concatenate 'simple-string
  36                                           "LOAD-SYMBOL-"
  37                                           (string slot))))
  38              (storer (intern (concatenate 'simple-string
  39                                           "STORE-SYMBOL-"
  40                                           (string slot))))
  41              (offset (intern (concatenate 'simple-string
  42                                           "SYMBOL-"
  43                                           (string slot)
  44                                           "-SLOT")
  45                              (find-package "SB!VM"))))
  46          `(progn
  47             (defmacro ,loader (reg symbol)
  48               `(inst ld ,reg null-tn
  49                      (+ (static-symbol-offset ',symbol)
  50                         (ash ,',offset word-shift)
  51                         (- other-pointer-lowtag))))
  52             (defmacro ,storer (reg symbol)
  53               `(inst st ,reg null-tn
  54                      (+ (static-symbol-offset ',symbol)
  55                         (ash ,',offset word-shift)
  56                         (- other-pointer-lowtag))))))))
  57   (frob value)
  58   (frob function))
  59
  60 (defmacro load-type (target source &optional (offset 0))
  61   #!+sb-doc
  62   "Loads the type bits of a pointer into target independent of
  63   byte-ordering issues."
  64   (once-only ((n-target target)
  65               (n-source source)
  66               (n-offset offset))
  67     ;; FIXME: although I don't understand entirely, I'm going to do
  68     ;; what whn does in x86/macros.lisp -- Christophe
  69     (ecase *backend-byte-order*
  70       (:little-endian
  71        `(inst ldub ,n-target ,n-source ,n-offset))
  72       (:big-endian
  73        `(inst ldub ,n-target ,n-source (+ ,n-offset 3))))))
  74
  75 ;;; Macros to handle the fact that we cannot use the machine native call and
  76 ;;; return instructions.
  77
  78 (defmacro lisp-jump (fun)
  79   "Jump to the lisp function FUNCTION.  LIP is an interior-reg temporary."
  80   `(progn
  81      (inst j ,fun
  82            (- (ash simple-fun-code-offset word-shift) fun-pointer-lowtag))
  83      (move code-tn ,fun)))
  84
  85 (defmacro lisp-return (return-pc &key (offset 0) (frob-code t))
  86   "Return to RETURN-PC."
  87   `(progn
  88      (inst j ,return-pc
  89            (- (* (1+ ,offset) n-word-bytes) other-pointer-lowtag))
  90      ,(if frob-code
  91           `(move code-tn ,return-pc)
  92           '(inst nop))))
  93
  94 (defmacro emit-return-pc (label)
  95   "Emit a return-pc header word.  LABEL is the label to use for this return-pc."
  96   `(progn
  97      (align n-lowtag-bits)
  98      (emit-label ,label)
  99      (inst lra-header-word)))
 100
 101
 102 \f
 103 ;;;; Stack TN's
 104
 105 ;;; Load-Stack-TN, Store-Stack-TN  --  Interface
 106 ;;;
 107 ;;;    Move a stack TN to a register and vice-versa.
 108 ;;;
 109 (defmacro load-stack-tn (reg stack)
 110   `(let ((reg ,reg)
 111          (stack ,stack))
 112      (let ((offset (tn-offset stack)))
 113        (sc-case stack
 114          ((control-stack)
 115           (loadw reg cfp-tn offset))))))
 116
 117 (defmacro store-stack-tn (stack reg)
 118   `(let ((stack ,stack)
 119          (reg ,reg))
 120      (let ((offset (tn-offset stack)))
 121        (sc-case stack
 122          ((control-stack)
 123           (storew reg cfp-tn offset))))))
 124
 125
 126 ;;; MAYBE-LOAD-STACK-TN  --  Interface
 127 ;;;
 128 (defmacro maybe-load-stack-tn (reg reg-or-stack)
 129   "Move the TN Reg-Or-Stack into Reg if it isn't already there."
 130   (once-only ((n-reg reg)
 131               (n-stack reg-or-stack))
 132     `(sc-case ,n-reg
 133        ((any-reg descriptor-reg)
 134         (sc-case ,n-stack
 135           ((any-reg descriptor-reg)
 136            (move ,n-reg ,n-stack))
 137           ((control-stack)
 138            (loadw ,n-reg cfp-tn (tn-offset ,n-stack))))))))
 139
 140 \f
 141 ;;;; Storage allocation:
 142
 143 (defmacro with-fixed-allocation ((result-tn temp-tn type-code size)
 144                                  &body body)
 145   "Do stuff to allocate an other-pointer object of fixed Size with a single
 146   word header having the specified Type-Code.  The result is placed in
 147   Result-TN, and Temp-TN is a non-descriptor temp (which may be randomly used
 148   by the body.)  The body is placed inside the PSEUDO-ATOMIC, and presumably
 149   initializes the object."
 150   (once-only ((result-tn result-tn) (temp-tn temp-tn)
 151               (type-code type-code) (size size))
 152     `(pseudo-atomic (:extra (pad-data-block ,size))
 153        (inst or ,result-tn alloc-tn other-pointer-lowtag)
 154        (inst li ,temp-tn (logior (ash (1- ,size) n-widetag-bits) ,type-code))
 155        (storew ,temp-tn ,result-tn 0 other-pointer-lowtag)
 156        ,@body)))
 157
 158 \f
 159 ;;;; Error Code
 160
 161 (defvar *adjustable-vectors* nil)
 162
 163 (defmacro with-adjustable-vector ((var) &rest body)
 164   `(let ((,var (or (pop *adjustable-vectors*)
 165                    (make-array 16
 166                                :element-type '(unsigned-byte 8)
 167                                :fill-pointer 0
 168                                :adjustable t))))
 169      (declare (type (vector (unsigned-byte 8) 16) ,var))
 170      (setf (fill-pointer ,var) 0)
 171      (unwind-protect
 172          (progn
 173            ,@body)
 174        (push ,var *adjustable-vectors*))))
 175
 176 (eval-when (:compile-toplevel :load-toplevel :execute)
 177   (defun emit-error-break (vop kind code values)
 178     (let ((vector (gensym)))
 179       `((let ((vop ,vop))
 180           (when vop
 181             (note-this-location vop :internal-error)))
 182         (inst unimp ,kind)
 183         (with-adjustable-vector (,vector)
 184           (write-var-integer (error-number-or-lose ',code) ,vector)
 185           ,@(mapcar #'(lambda (tn)
 186                         `(let ((tn ,tn))
 187                            (write-var-integer (make-sc-offset (sc-number
 188                                                                (tn-sc tn))
 189                                                               (tn-offset tn))
 190                                               ,vector)))
 191                     values)
 192           (inst byte (length ,vector))
 193           (dotimes (i (length ,vector))
 194             (inst byte (aref ,vector i))))
 195         (align word-shift)))))
 196
 197 (defmacro error-call (vop error-code &rest values)
 198   "Cause an error.  ERROR-CODE is the error to cause."
 199   (cons 'progn
 200         (emit-error-break vop error-trap error-code values)))
 201
 202
 203 (defmacro cerror-call (vop label error-code &rest values)
 204   "Cause a continuable error.  If the error is continued, execution resumes at
 205   LABEL."
 206   `(progn
 207      (inst b ,label)
 208      ,@(emit-error-break vop cerror-trap error-code values)))
 209
 210 (defmacro generate-error-code (vop error-code &rest values)
 211   "Generate-Error-Code Error-code Value*
 212   Emit code for an error with the specified Error-Code and context Values."
 213   `(assemble (*elsewhere*)
 214      (let ((start-lab (gen-label)))
 215        (emit-label start-lab)
 216        (error-call ,vop ,error-code ,@values)
 217        start-lab)))
 218
 219 (defmacro generate-cerror-code (vop error-code &rest values)
 220   "Generate-CError-Code Error-code Value*
 221   Emit code for a continuable error with the specified Error-Code and
 222   context Values.  If the error is continued, execution resumes after
 223   the GENERATE-CERROR-CODE form."
 224   (let ((continue (gensym "CONTINUE-LABEL-"))
 225         (error (gensym "ERROR-LABEL-")))
 226     `(let ((,continue (gen-label)))
 227        (emit-label ,continue)
 228        (assemble (*elsewhere*)
 229          (let ((,error (gen-label)))
 230            (emit-label ,error)
 231            (cerror-call ,vop ,continue ,error-code ,@values)
 232            ,error)))))
 233
 234
 235 \f
 236 ;;; a handy macro for making sequences look atomic
 237 (defmacro pseudo-atomic ((&key (extra 0)) &rest forms)
 238   (let ((n-extra (gensym)))
 239     `(let ((,n-extra ,extra))
 240        ;; Set the pseudo-atomic flag.
 241        (without-scheduling ()
 242          (inst add alloc-tn 4))
 243        ,@forms
 244        ;; Reset the pseudo-atomic flag.
 245        (without-scheduling ()
 246          #+nil (inst taddcctv alloc-tn (- ,n-extra 4))
 247         ;; Remove the pseudo-atomic flag.
 248         (inst add alloc-tn (- ,n-extra 4))
 249         ;; Check to see if pseudo-atomic interrupted flag is set (bit 0 = 1).
 250         (inst andcc zero-tn alloc-tn 3)
 251         ;; The C code needs to process this correctly and fixup alloc-tn.
 252         (inst t :ne pseudo-atomic-trap)))))
 253
 254 ;;; FIXME: test typing macros. Should(?) be in type-vops.lisp, except
 255 ;;; that they're also used in subprim.lisp
 256
 257 (defun cost-to-test-types (type-codes)
 258   (+ (* 2 (length type-codes))
 259      (if (> (apply #'max type-codes) lowtag-limit) 7 2)))
 260
 261 (defparameter *immediate-types*
 262   (list base-char-widetag unbound-marker-widetag))
 263
 264 (defparameter *fun-header-widetags*
 265   (list funcallable-instance-header-widetag
 266         simple-fun-header-widetag
 267         closure-fun-header-widetag
 268         closure-header-widetag))
 269
 270 (defun gen-range-test (reg target not-target not-p min seperation max values)
 271   (let ((tests nil)
 272         (start nil)
 273         (end nil)
 274         (insts nil))
 275     (multiple-value-bind (equal less-or-equal greater-or-equal label)
 276         (if not-p
 277             (values :ne :gt :lt not-target)
 278             (values :eq :le :ge target))
 279       (flet ((emit-test ()
 280                (if (= start end)
 281                    (push start tests)
 282                    (push (cons start end) tests))))
 283         (dolist (value values)
 284           (cond ((< value min)
 285                  (error "~S is less than the specified minimum of ~S"
 286                         value min))
 287                 ((> value max)
 288                  (error "~S is greater than the specified maximum of ~S"
 289                         value max))
 290                 ((not (zerop (rem (- value min) seperation)))
 291                  (error "~S isn't an even multiple of ~S from ~S"
 292                         value seperation min))
 293                 ((null start)
 294                  (setf start value))
 295                 ((> value (+ end seperation))
 296                  (emit-test)
 297                  (setf start value)))
 298           (setf end value))
 299         (emit-test))
 300       (macrolet ((inst (name &rest args)
 301                    `(push (list 'inst ',name ,@args) insts)))
 302         (do ((remaining (nreverse tests) (cdr remaining)))
 303             ((null remaining))
 304           (let ((test (car remaining))
 305                 (last (null (cdr remaining))))
 306             (if (atom test)
 307                 (progn
 308                   (inst cmp reg test)
 309                   (if last
 310                       (inst b equal target)
 311                       (inst b :eq label)))
 312                 (let ((start (car test))
 313                       (end (cdr test)))
 314                   (cond ((and (= start min) (= end max))
 315                          (warn "The values ~S cover the entire range from ~
 316                          ~S to ~S [step ~S]."
 317                                values min max seperation)
 318                          (push `(unless ,not-p (inst b ,target)) insts))
 319                         ((= start min)
 320                          (inst cmp reg end)
 321                          (if last
 322                              (inst b less-or-equal target)
 323                              (inst b :le label)))
 324                         ((= end max)
 325                          (inst cmp reg start)
 326                          (if last
 327                              (inst b greater-or-equal target)
 328                              (inst b :ge label)))
 329                         (t
 330                          (inst cmp reg start)
 331                          (inst b :lt (if not-p target not-target))
 332                          (inst cmp reg end)
 333                          (if last
 334                              (inst b less-or-equal target)
 335                              (inst b :le label))))))))))
 336     (nreverse insts)))
 337
 338 (defun gen-other-immediate-test (reg target not-target not-p values)
 339   (gen-range-test reg target not-target not-p
 340                   (+ other-immediate-0-lowtag lowtag-limit)
 341                   (- other-immediate-1-lowtag other-immediate-0-lowtag)
 342                   (ash 1 n-widetag-bits)
 343                   values))
 344
 345 (defun test-type-aux (reg temp target not-target not-p lowtags immed hdrs
 346                       function-p)
 347   (let* ((fixnump (and (member even-fixnum-lowtag lowtags :test #'eql)
 348                        (member odd-fixnum-lowtag lowtags :test #'eql)))
 349          (lowtags (sort (if fixnump
 350                             (delete even-fixnum-lowtag
 351                                     (remove odd-fixnum-lowtag lowtags
 352                                             :test #'eql)
 353                                     :test #'eql)
 354                             (copy-list lowtags))
 355                         #'<))
 356          (lowtag (if function-p
 357                      fun-pointer-lowtag
 358                      other-pointer-lowtag))
 359          (hdrs (sort (copy-list hdrs) #'<))
 360          (immed (sort (copy-list immed) #'<)))
 361     (append
 362      (when immed
 363        `((inst and ,temp ,reg widetag-mask)
 364          ,@(if (or fixnump lowtags hdrs)
 365                (let ((fall-through (gensym)))
 366                  `((let (,fall-through (gen-label))
 367                      ,@(gen-other-immediate-test
 368                         temp (if not-p not-target target)
 369                         fall-through nil immed)
 370                      (emit-label ,fall-through))))
 371                (gen-other-immediate-test temp target not-target not-p immed))))
 372      (when fixnump
 373        `((inst andcc zero-tn ,reg fixnum-tag-mask)
 374          ,(if (or lowtags hdrs)
 375               `(if (member :sparc-v9 *backend-subfeatures*)
 376                    (inst b :eq ,(if not-p not-target target) ,(if not-p :pn :pt))
 377                    (inst b :eq ,(if not-p not-target target)))
 378               `(if (member :sparc-v9 *backend-subfeatures*)
 379                    (inst b ,(if not-p :ne :eq) ,target ,(if not-p :pn :pt))
 380                    (inst b ,(if not-p :ne :eq) ,target)))))
 381      (when (or lowtags hdrs)
 382        `((inst and ,temp ,reg lowtag-mask)))
 383      (when lowtags
 384        (if hdrs
 385            (let ((fall-through (gensym)))
 386              `((let ((,fall-through (gen-label)))
 387                  ,@(gen-range-test temp (if not-p not-target target)
 388                                    fall-through nil
 389                                    0 1 (1- lowtag-limit) lowtags)
 390                  (emit-label ,fall-through))))
 391            (gen-range-test temp target not-target not-p 0 1
 392                            (1- lowtag-limit) lowtags)))
 393      (when hdrs
 394        `((inst cmp ,temp ,lowtag)
 395          (if (member :sparc-v9 *backend-subfeatures*)
 396              (inst b :ne ,(if not-p target not-target) ,(if not-p :pn :pt))
 397              (inst b :ne ,(if not-p target not-target)))
 398          (inst nop)
 399          (load-type ,temp ,reg (- ,lowtag))
 400          ,@(gen-other-immediate-test temp target not-target not-p hdrs))))))
 401
 402 (defmacro test-type (register temp target not-p &rest type-codes)
 403   (let* ((type-codes (mapcar #'eval type-codes))
 404          (lowtags (remove lowtag-limit type-codes :test #'<))
 405          (extended (remove lowtag-limit type-codes :test #'>))
 406          (immediates (intersection extended *immediate-types* :test #'eql))
 407          (headers (set-difference extended *immediate-types* :test #'eql))
 408          (function-p nil))
 409     (unless type-codes
 410       (error "Must supply at least on type for test-type."))
 411     (when (and headers (member other-pointer-lowtag lowtags))
 412       (warn "OTHER-POINTER-TYPE supersedes the use of ~S" headers)
 413       (setf headers nil))
 414     (when (and immediates
 415                (or (member other-immediate-0-lowtag lowtags)
 416                    (member other-immediate-1-lowtag lowtags)))
 417       (warn "OTHER-IMMEDIATE-n-TYPE supersedes the use of ~S" immediates)
 418       (setf immediates nil))
 419     (when (intersection headers *fun-header-widetags*)
 420       (unless (subsetp headers *fun-header-widetags*)
 421         (error "Can't test for mix of function subtypes and normal ~
 422                 header types."))
 423       (setq function-p t))
 424
 425     (let ((n-reg (gensym))
 426           (n-temp (gensym))
 427           (n-target (gensym))
 428           (not-target (gensym)))
 429       `(let ((,n-reg ,register)
 430              (,n-temp ,temp)
 431              (,n-target ,target)
 432              (,not-target (gen-label)))
 433         (declare (ignorable ,n-temp))
 434         ,@(if (constantp not-p)
 435               (test-type-aux n-reg n-temp n-target not-target
 436                              (eval not-p) lowtags immediates headers
 437                              function-p)
 438               `((cond (,not-p
 439                        ,@(test-type-aux n-reg n-temp n-target not-target t
 440                                         lowtags immediates headers
 441                                         function-p))
 442                       (t
 443                        ,@(test-type-aux n-reg n-temp n-target not-target nil
 444                                         lowtags immediates headers
 445                                         function-p)))))
 446         (inst nop)
 447         (emit-label ,not-target)))))