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      (setf (fill-pointer ,var) 0)
 170      (unwind-protect
 171          (progn
 172            ,@body)
 173        (push ,var *adjustable-vectors*))))
 174
 175 (eval-when (:compile-toplevel :load-toplevel :execute)
 176   (defun emit-error-break (vop kind code values)
 177     (let ((vector (gensym)))
 178       `((let ((vop ,vop))
 179           (when vop
 180             (note-this-location vop :internal-error)))
 181         (inst unimp ,kind)
 182         (with-adjustable-vector (,vector)
 183           (write-var-integer (error-number-or-lose ',code) ,vector)
 184           ,@(mapcar #'(lambda (tn)
 185                         `(let ((tn ,tn))
 186                            (write-var-integer (make-sc-offset (sc-number
 187                                                                (tn-sc tn))
 188                                                               (tn-offset tn))
 189                                               ,vector)))
 190                     values)
 191           (inst byte (length ,vector))
 192           (dotimes (i (length ,vector))
 193             (inst byte (aref ,vector i))))
 194         (align word-shift)))))
 195
 196 (defmacro error-call (vop error-code &rest values)
 197   "Cause an error.  ERROR-CODE is the error to cause."
 198   (cons 'progn
 199         (emit-error-break vop error-trap error-code values)))
 200
 201
 202 (defmacro cerror-call (vop label error-code &rest values)
 203   "Cause a continuable error.  If the error is continued, execution resumes at
 204   LABEL."
 205   `(progn
 206      (inst b ,label)
 207      ,@(emit-error-break vop cerror-trap error-code values)))
 208
 209 (defmacro generate-error-code (vop error-code &rest values)
 210   "Generate-Error-Code Error-code Value*
 211   Emit code for an error with the specified Error-Code and context Values."
 212   `(assemble (*elsewhere*)
 213      (let ((start-lab (gen-label)))
 214        (emit-label start-lab)
 215        (error-call ,vop ,error-code ,@values)
 216        start-lab)))
 217
 218 (defmacro generate-cerror-code (vop error-code &rest values)
 219   "Generate-CError-Code Error-code Value*
 220   Emit code for a continuable error with the specified Error-Code and
 221   context Values.  If the error is continued, execution resumes after
 222   the GENERATE-CERROR-CODE form."
 223   (let ((continue (gensym "CONTINUE-LABEL-"))
 224         (error (gensym "ERROR-LABEL-")))
 225     `(let ((,continue (gen-label)))
 226        (emit-label ,continue)
 227        (assemble (*elsewhere*)
 228          (let ((,error (gen-label)))
 229            (emit-label ,error)
 230            (cerror-call ,vop ,continue ,error-code ,@values)
 231            ,error)))))
 232
 233
 234 \f
 235 ;;; a handy macro for making sequences look atomic
 236 (defmacro pseudo-atomic ((&key (extra 0)) &rest forms)
 237   (let ((n-extra (gensym)))
 238     `(let ((,n-extra ,extra))
 239        ;; Set the pseudo-atomic flag.
 240        (without-scheduling ()
 241          (inst add alloc-tn 4))
 242        ,@forms
 243        ;; Reset the pseudo-atomic flag.
 244        (without-scheduling ()
 245          #+nil (inst taddcctv alloc-tn (- ,n-extra 4))
 246         ;; Remove the pseudo-atomic flag.
 247         (inst add alloc-tn (- ,n-extra 4))
 248         ;; Check to see if pseudo-atomic interrupted flag is set (bit 0 = 1).
 249         (inst andcc zero-tn alloc-tn 3)
 250         ;; The C code needs to process this correctly and fixup alloc-tn.
 251         (inst t :ne pseudo-atomic-trap)))))
 252
 253 ;;; FIXME: test typing macros. Should(?) be in type-vops.lisp, except
 254 ;;; that they're also used in subprim.lisp
 255
 256 (defun cost-to-test-types (type-codes)
 257   (+ (* 2 (length type-codes))
 258      (if (> (apply #'max type-codes) lowtag-limit) 7 2)))
 259
 260 (defparameter *immediate-types*
 261   (list base-char-widetag unbound-marker-widetag))
 262
 263 (defparameter *fun-header-widetags*
 264   (list funcallable-instance-header-widetag
 265         simple-fun-header-widetag
 266         closure-fun-header-widetag
 267         closure-header-widetag))
 268
 269 (defun gen-range-test (reg target not-target not-p min seperation max values)
 270   (let ((tests nil)
 271         (start nil)
 272         (end nil)
 273         (insts nil))
 274     (multiple-value-bind (equal less-or-equal greater-or-equal label)
 275         (if not-p
 276             (values :ne :gt :lt not-target)
 277             (values :eq :le :ge target))
 278       (flet ((emit-test ()
 279                (if (= start end)
 280                    (push start tests)
 281                    (push (cons start end) tests))))
 282         (dolist (value values)
 283           (cond ((< value min)
 284                  (error "~S is less than the specified minimum of ~S"
 285                         value min))
 286                 ((> value max)
 287                  (error "~S is greater than the specified maximum of ~S"
 288                         value max))
 289                 ((not (zerop (rem (- value min) seperation)))
 290                  (error "~S isn't an even multiple of ~S from ~S"
 291                         value seperation min))
 292                 ((null start)
 293                  (setf start value))
 294                 ((> value (+ end seperation))
 295                  (emit-test)
 296                  (setf start value)))
 297           (setf end value))
 298         (emit-test))
 299       (macrolet ((inst (name &rest args)
 300                    `(push (list 'inst ',name ,@args) insts)))
 301         (do ((remaining (nreverse tests) (cdr remaining)))
 302             ((null remaining))
 303           (let ((test (car remaining))
 304                 (last (null (cdr remaining))))
 305             (if (atom test)
 306                 (progn
 307                   (inst cmp reg test)
 308                   (if last
 309                       (inst b equal target)
 310                       (inst b :eq label)))
 311                 (let ((start (car test))
 312                       (end (cdr test)))
 313                   (cond ((and (= start min) (= end max))
 314                          (warn "The values ~S cover the entire range from ~
 315                          ~S to ~S [step ~S]."
 316                                values min max seperation)
 317                          (push `(unless ,not-p (inst b ,target)) insts))
 318                         ((= start min)
 319                          (inst cmp reg end)
 320                          (if last
 321                              (inst b less-or-equal target)
 322                              (inst b :le label)))
 323                         ((= end max)
 324                          (inst cmp reg start)
 325                          (if last
 326                              (inst b greater-or-equal target)
 327                              (inst b :ge label)))
 328                         (t
 329                          (inst cmp reg start)
 330                          (inst b :lt (if not-p target not-target))
 331                          (inst cmp reg end)
 332                          (if last
 333                              (inst b less-or-equal target)
 334                              (inst b :le label))))))))))
 335     (nreverse insts)))
 336
 337 (defun gen-other-immediate-test (reg target not-target not-p values)
 338   (gen-range-test reg target not-target not-p
 339                   (+ other-immediate-0-lowtag lowtag-limit)
 340                   (- other-immediate-1-lowtag other-immediate-0-lowtag)
 341                   (ash 1 n-widetag-bits)
 342                   values))
 343
 344 (defun test-type-aux (reg temp target not-target not-p lowtags immed hdrs
 345                       function-p)
 346   (let* ((fixnump (and (member even-fixnum-lowtag lowtags :test #'eql)
 347                        (member odd-fixnum-lowtag lowtags :test #'eql)))
 348          (lowtags (sort (if fixnump
 349                             (delete even-fixnum-lowtag
 350                                     (remove odd-fixnum-lowtag lowtags
 351                                             :test #'eql)
 352                                     :test #'eql)
 353                             (copy-list lowtags))
 354                         #'<))
 355          (lowtag (if function-p
 356                      fun-pointer-lowtag
 357                      other-pointer-lowtag))
 358          (hdrs (sort (copy-list hdrs) #'<))
 359          (immed (sort (copy-list immed) #'<)))
 360     (append
 361      (when immed
 362        `((inst and ,temp ,reg widetag-mask)
 363          ,@(if (or fixnump lowtags hdrs)
 364                (let ((fall-through (gensym)))
 365                  `((let (,fall-through (gen-label))
 366                      ,@(gen-other-immediate-test
 367                         temp (if not-p not-target target)
 368                         fall-through nil immed)
 369                      (emit-label ,fall-through))))
 370                (gen-other-immediate-test temp target not-target not-p immed))))
 371      (when fixnump
 372        `((inst andcc zero-tn ,reg fixnum-tag-mask)
 373          ,(if (or lowtags hdrs)
 374               `(if (member :sparc-v9 *backend-subfeatures*)
 375                    (inst b :eq ,(if not-p not-target target) ,(if not-p :pn :pt))
 376                    (inst b :eq ,(if not-p not-target target)))
 377               `(if (member :sparc-v9 *backend-subfeatures*)
 378                    (inst b ,(if not-p :ne :eq) ,target ,(if not-p :pn :pt))
 379                    (inst b ,(if not-p :ne :eq) ,target)))))
 380      (when (or lowtags hdrs)
 381        `((inst and ,temp ,reg lowtag-mask)))
 382      (when lowtags
 383        (if hdrs
 384            (let ((fall-through (gensym)))
 385              `((let ((,fall-through (gen-label)))
 386                  ,@(gen-range-test temp (if not-p not-target target)
 387                                    fall-through nil
 388                                    0 1 (1- lowtag-limit) lowtags)
 389                  (emit-label ,fall-through))))
 390            (gen-range-test temp target not-target not-p 0 1
 391                            (1- lowtag-limit) lowtags)))
 392      (when hdrs
 393        `((inst cmp ,temp ,lowtag)
 394          (if (member :sparc-v9 *backend-subfeatures*)
 395              (inst b :ne ,(if not-p target not-target) ,(if not-p :pn :pt))
 396              (inst b :ne ,(if not-p target not-target)))
 397          (inst nop)
 398          (load-type ,temp ,reg (- ,lowtag))
 399          ,@(gen-other-immediate-test temp target not-target not-p hdrs))))))
 400
 401 (defmacro test-type (register temp target not-p &rest type-codes)
 402   (let* ((type-codes (mapcar #'eval type-codes))
 403          (lowtags (remove lowtag-limit type-codes :test #'<))
 404          (extended (remove lowtag-limit type-codes :test #'>))
 405          (immediates (intersection extended *immediate-types* :test #'eql))
 406          (headers (set-difference extended *immediate-types* :test #'eql))
 407          (function-p nil))
 408     (unless type-codes
 409       (error "Must supply at least on type for test-type."))
 410     (when (and headers (member other-pointer-lowtag lowtags))
 411       (warn "OTHER-POINTER-TYPE supersedes the use of ~S" headers)
 412       (setf headers nil))
 413     (when (and immediates
 414                (or (member other-immediate-0-lowtag lowtags)
 415                    (member other-immediate-1-lowtag lowtags)))
 416       (warn "OTHER-IMMEDIATE-n-TYPE supersedes the use of ~S" immediates)
 417       (setf immediates nil))
 418     (when (intersection headers *fun-header-widetags*)
 419       (unless (subsetp headers *fun-header-widetags*)
 420         (error "Can't test for mix of function subtypes and normal ~
 421                 header types."))
 422       (setq function-p t))
 423
 424     (let ((n-reg (gensym))
 425           (n-temp (gensym))
 426           (n-target (gensym))
 427           (not-target (gensym)))
 428       `(let ((,n-reg ,register)
 429              (,n-temp ,temp)
 430              (,n-target ,target)
 431              (,not-target (gen-label)))
 432         (declare (ignorable ,n-temp))
 433         ,@(if (constantp not-p)
 434               (test-type-aux n-reg n-temp n-target not-target
 435                              (eval not-p) lowtags immediates headers
 436                              function-p)
 437               `((cond (,not-p
 438                        ,@(test-type-aux n-reg n-temp n-target not-target t
 439                                         lowtags immediates headers
 440                                         function-p))
 441                       (t
 442                        ,@(test-type-aux n-reg n-temp n-target not-target nil
 443                                         lowtags immediates headers
 444                                         function-p)))))
 445         (inst nop)
 446         (emit-label ,not-target)))))