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 ;;; PSEUDO-ATOMIC -- Handy macro for making sequences look atomic.
 236 ;;;
 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
 255 ;;; FIXME: test typing macros. Should(?) be in type-vops.lisp, except
 256 ;;; that they're also used in subprim.lisp
 257
 258 (defun cost-to-test-types (type-codes)
 259   (+ (* 2 (length type-codes))
 260      (if (> (apply #'max type-codes) lowtag-limit) 7 2)))
 261
 262 (defparameter *immediate-types*
 263   (list base-char-widetag unbound-marker-widetag))
 264
 265 (defparameter *fun-header-widetags*
 266   (list funcallable-instance-header-widetag
 267         simple-fun-header-widetag
 268         closure-fun-header-widetag
 269         closure-header-widetag))
 270
 271 (defun gen-range-test (reg target not-target not-p min seperation max values)
 272   (let ((tests nil)
 273         (start nil)
 274         (end nil)
 275         (insts nil))
 276     (multiple-value-bind (equal less-or-equal greater-or-equal label)
 277         (if not-p
 278             (values :ne :gt :lt not-target)
 279             (values :eq :le :ge target))
 280       (flet ((emit-test ()
 281                (if (= start end)
 282                    (push start tests)
 283                    (push (cons start end) tests))))
 284         (dolist (value values)
 285           (cond ((< value min)
 286                  (error "~S is less than the specified minimum of ~S"
 287                         value min))
 288                 ((> value max)
 289                  (error "~S is greater than the specified maximum of ~S"
 290                         value max))
 291                 ((not (zerop (rem (- value min) seperation)))
 292                  (error "~S isn't an even multiple of ~S from ~S"
 293                         value seperation min))
 294                 ((null start)
 295                  (setf start value))
 296                 ((> value (+ end seperation))
 297                  (emit-test)
 298                  (setf start value)))
 299           (setf end value))
 300         (emit-test))
 301       (macrolet ((inst (name &rest args)
 302                    `(push (list 'inst ',name ,@args) insts)))
 303         (do ((remaining (nreverse tests) (cdr remaining)))
 304             ((null remaining))
 305           (let ((test (car remaining))
 306                 (last (null (cdr remaining))))
 307             (if (atom test)
 308                 (progn
 309                   (inst cmp reg test)
 310                   (if last
 311                       (inst b equal target)
 312                       (inst b :eq label)))
 313                 (let ((start (car test))
 314                       (end (cdr test)))
 315                   (cond ((and (= start min) (= end max))
 316                          (warn "The values ~S cover the entire range from ~
 317                          ~S to ~S [step ~S]."
 318                                values min max seperation)
 319                          (push `(unless ,not-p (inst b ,target)) insts))
 320                         ((= start min)
 321                          (inst cmp reg end)
 322                          (if last
 323                              (inst b less-or-equal target)
 324                              (inst b :le label)))
 325                         ((= end max)
 326                          (inst cmp reg start)
 327                          (if last
 328                              (inst b greater-or-equal target)
 329                              (inst b :ge label)))
 330                         (t
 331                          (inst cmp reg start)
 332                          (inst b :lt (if not-p target not-target))
 333                          (inst cmp reg end)
 334                          (if last
 335                              (inst b less-or-equal target)
 336                              (inst b :le label))))))))))
 337     (nreverse insts)))
 338
 339 (defun gen-other-immediate-test (reg target not-target not-p values)
 340   (gen-range-test reg target not-target not-p
 341                   (+ other-immediate-0-lowtag lowtag-limit)
 342                   (- other-immediate-1-lowtag other-immediate-0-lowtag)
 343                   (ash 1 n-widetag-bits)
 344                   values))
 345
 346 (defun test-type-aux (reg temp target not-target not-p lowtags immed hdrs
 347                       function-p)
 348   (let* ((fixnump (and (member even-fixnum-lowtag lowtags :test #'eql)
 349                        (member odd-fixnum-lowtag lowtags :test #'eql)))
 350          (lowtags (sort (if fixnump
 351                             (delete even-fixnum-lowtag
 352                                     (remove odd-fixnum-lowtag lowtags
 353                                             :test #'eql)
 354                                     :test #'eql)
 355                             (copy-list lowtags))
 356                         #'<))
 357          (lowtag (if function-p
 358                      fun-pointer-lowtag
 359                      other-pointer-lowtag))
 360          (hdrs (sort (copy-list hdrs) #'<))
 361          (immed (sort (copy-list immed) #'<)))
 362     (append
 363      (when immed
 364        `((inst and ,temp ,reg widetag-mask)
 365          ,@(if (or fixnump lowtags hdrs)
 366                (let ((fall-through (gensym)))
 367                  `((let (,fall-through (gen-label))
 368                      ,@(gen-other-immediate-test
 369                         temp (if not-p not-target target)
 370                         fall-through nil immed)
 371                      (emit-label ,fall-through))))
 372                (gen-other-immediate-test temp target not-target not-p immed))))
 373      (when fixnump
 374        `((inst andcc zero-tn ,reg fixnum-tag-mask)
 375          ,(if (or lowtags hdrs)
 376               `(inst b :eq ,(if not-p not-target target)
 377                 #!+sparc-v9 ,(if not-p :pn :pt))
 378               `(inst b ,(if not-p :ne :eq) ,target
 379                 #!+sparc-v9 ,(if not-p :pn :pt)))))
 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          (inst b :ne ,(if not-p target not-target)
 395           #!+sparc-v9 ,(if not-p :pn :pt))
 396          (inst nop)
 397          (load-type ,temp ,reg (- ,lowtag))
 398          ,@(gen-other-immediate-test temp target not-target not-p hdrs))))))
 399
 400 (defmacro test-type (register temp target not-p &rest type-codes)
 401   (let* ((type-codes (mapcar #'eval type-codes))
 402          (lowtags (remove lowtag-limit type-codes :test #'<))
 403          (extended (remove lowtag-limit type-codes :test #'>))
 404          (immediates (intersection extended *immediate-types* :test #'eql))
 405          (headers (set-difference extended *immediate-types* :test #'eql))
 406          (function-p nil))
 407     (unless type-codes
 408       (error "Must supply at least on type for test-type."))
 409     (when (and headers (member other-pointer-lowtag lowtags))
 410       (warn "OTHER-POINTER-TYPE supersedes the use of ~S" headers)
 411       (setf headers nil))
 412     (when (and immediates
 413                (or (member other-immediate-0-lowtag lowtags)
 414                    (member other-immediate-1-lowtag lowtags)))
 415       (warn "OTHER-IMMEDIATE-n-TYPE supersedes the use of ~S" immediates)
 416       (setf immediates nil))
 417     (when (intersection headers *fun-header-widetags*)
 418       (unless (subsetp headers *fun-header-widetags*)
 419         (error "Can't test for mix of function subtypes and normal ~
 420                 header types."))
 421       (setq function-p t))
 422
 423     (let ((n-reg (gensym))
 424           (n-temp (gensym))
 425           (n-target (gensym))
 426           (not-target (gensym)))
 427       `(let ((,n-reg ,register)
 428              (,n-temp ,temp)
 429              (,n-target ,target)
 430              (,not-target (gen-label)))
 431         (declare (ignorable ,n-temp))
 432         ,@(if (constantp not-p)
 433               (test-type-aux n-reg n-temp n-target not-target
 434                              (eval not-p) lowtags immediates headers
 435                              function-p)
 436               `((cond (,not-p
 437                        ,@(test-type-aux n-reg n-temp n-target not-target t
 438                                         lowtags immediates headers
 439                                         function-p))
 440                       (t
 441                        ,@(test-type-aux n-reg n-temp n-target not-target nil
 442                                         lowtags immediates headers
 443                                         function-p)))))
 444         (inst nop)
 445         (emit-label ,not-target)))))