src/compiler/ppc/macros.lisp

   1 ;;;; a bunch of handy macros for the PPC
   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 mr ,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 lwz word-shift)
  28   (frob storew stw word-shift))
  29
  30 (defmacro load-symbol (reg symbol)
  31   `(inst addi ,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 lwz ,reg null-tn
  49                      (+ (static-symbol-offset ',symbol)
  50                         (ash ,',offset word-shift)
  51                         (- other-pointer-lowtag))))
  52             (defmacro ,storer (reg symbol)
  53               `(inst stw ,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   "Loads the type bits of a pointer into target independent of
  62   byte-ordering issues."
  63   (once-only ((n-target target)
  64               (n-source source)
  65               (n-offset offset))
  66     (ecase *backend-byte-order*
  67       (:little-endian
  68        `(inst lbz ,n-target ,n-source ,n-offset))
  69       (:big-endian
  70        `(inst lbz ,n-target ,n-source (+ ,n-offset 3))))))
  71
  72 ;;; Macros to handle the fact that we cannot use the machine native call and
  73 ;;; return instructions.
  74
  75 (defmacro lisp-jump (function lip)
  76   "Jump to the lisp function FUNCTION.  LIP is an interior-reg temporary."
  77   `(progn
  78     ;; something is deeply bogus.  look at this
  79     ;; (loadw ,lip ,function sb!vm:function-code-offset sb!vm:function-pointer-type)
  80     (inst addi ,lip ,function (- (* n-word-bytes sb!vm:simple-fun-code-offset) sb!vm:fun-pointer-lowtag))
  81     (inst mtctr ,lip)
  82     (move code-tn ,function)
  83     (inst bctr)))
  84
  85 (defmacro lisp-return (return-pc lip &key (offset 0) (frob-code t))
  86   "Return to RETURN-PC."
  87   `(progn
  88      (inst addi ,lip ,return-pc (- (* (1+ ,offset) n-word-bytes) other-pointer-lowtag))
  89      (inst mtlr ,lip)
  90      ,@(if frob-code
  91          `((move code-tn ,return-pc)))
  92      (inst blr)))
  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 flag-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) (flag-tn flag-tn)
 151               (type-code type-code) (size size))
 152     `(pseudo-atomic (,flag-tn :extra (pad-data-block ,size))
 153        (inst ori ,result-tn alloc-tn other-pointer-lowtag)
 154        (inst lr ,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 ;;;; Type testing noise.
 160
 161 ;;; GEN-RANGE-TEST -- internal
 162 ;;;
 163 ;;; Generate code that branches to TARGET iff REG contains one of VALUES.
 164 ;;; If NOT-P is true, invert the test.  Jumping to NOT-TARGET is the same
 165 ;;; as falling out the bottom.
 166 ;;;
 167
 168 #|
 169 (defun gen-range-test (reg target not-target not-p min seperation max values)
 170   (let ((tests nil)
 171         (start nil)
 172         (end nil)
 173         (insts nil))
 174     (multiple-value-bind (equal less-or-equal greater-or-equal label)
 175                          (if not-p
 176                              (values :ne :gt :lt not-target)
 177                              (values :eq :le :ge target))
 178       (flet ((emit-test ()
 179                (if (= start end)
 180                    (push start tests)
 181                    (push (cons start end) tests))))
 182         (dolist (value values)
 183           (cond ((< value min)
 184                  (error "~S is less than the specified minimum of ~S"
 185                         value min))
 186                 ((> value max)
 187                  (error "~S is greater than the specified maximum of ~S"
 188                         value max))
 189                 ((not (zerop (rem (- value min) seperation)))
 190                  (error "~S isn't an even multiple of ~S from ~S"
 191                         value seperation min))
 192                 ((null start)
 193                  (setf start value))
 194                 ((> value (+ end seperation))
 195                  (emit-test)
 196                  (setf start value)))
 197           (setf end value))
 198         (emit-test))
 199       (macrolet ((inst (name &rest args)
 200                        `(push (list 'inst ',name ,@args) insts)))
 201         (do ((remaining (nreverse tests) (cdr remaining)))
 202             ((null remaining))
 203           (let ((test (car remaining))
 204                 (last (null (cdr remaining))))
 205             (if (atom test)
 206                 (progn
 207                   (inst cmpwi reg test)
 208                   (if last
 209                       (inst b? equal target)
 210                       (inst beq label)))
 211                 (let ((start (car test))
 212                       (end (cdr test)))
 213                   (cond ((and (= start min) (= end max))
 214                          (warn "The values ~S cover the entire range from ~
 215                          ~S to ~S [step ~S]."
 216                                values min max seperation)
 217                          (push `(unless ,not-p (inst b ,target)) insts))
 218                         ((= start min)
 219                          (inst cmpwi reg end)
 220                          (if last
 221                              (inst b? less-or-equal target)
 222                              (inst ble label)))
 223                         ((= end max)
 224                          (inst cmpwi reg start)
 225                          (if last
 226                              (inst b? greater-or-equal target)
 227                              (inst bge label)))
 228                         (t
 229                          (inst cmpwi reg start)
 230                          (inst blt (if not-p target not-target))
 231                          (inst cmpwi reg end)
 232                          (if last
 233                              (inst b? less-or-equal target)
 234                              (inst ble label))))))))))
 235     (nreverse insts)))
 236
 237 (defun gen-other-immediate-test (reg target not-target not-p values)
 238   (gen-range-test reg target not-target not-p
 239                   (+ other-immediate-0-lowtag lowtag-limit)
 240                   (- other-immediate-1-lowtag other-immediate-0-lowtag)
 241                   (ash 1 n-widetag-bits)
 242                   values))
 243
 244
 245 (defun test-type-aux (reg temp target not-target not-p lowtags immed hdrs
 246                           function-p)
 247   (let* ((fixnump (and (member even-fixnum-lowtag lowtags :test #'eql)
 248                        (member odd-fixnum-lowtag lowtags :test #'eql)))
 249          (lowtags (sort (if fixnump
 250                             (delete even-fixnum-lowtag
 251                                     (remove odd-fixnum-lowtag lowtags
 252                                             :test #'eql)
 253                                     :test #'eql)
 254                             (copy-list lowtags))
 255                         #'<))
 256          (lowtag (if function-p
 257                      sb!vm:fun-pointer-lowtag
 258                      sb!vm:other-pointer-lowtag))
 259          (hdrs (sort (copy-list hdrs) #'<))
 260          (immed (sort (copy-list immed) #'<)))
 261     (append
 262      (when immed
 263        `((inst andi. ,temp ,reg widetag-mask)
 264          ,@(if (or fixnump lowtags hdrs)
 265                (let ((fall-through (gensym)))
 266                  `((let (,fall-through (gen-label))
 267                      ,@(gen-other-immediate-test
 268                         temp (if not-p not-target target)
 269                         fall-through nil immed)
 270                      (emit-label ,fall-through))))
 271                (gen-other-immediate-test temp target not-target not-p immed))))
 272      (when fixnump
 273        `((inst andi. ,temp ,reg 3)
 274          ,(if (or lowtags hdrs)
 275               `(inst beq ,(if not-p not-target target))
 276               `(inst b? ,(if not-p :ne :eq) ,target))))
 277      (when (or lowtags hdrs)
 278        `((inst andi. ,temp ,reg lowtag-mask)))
 279      (when lowtags
 280        (if hdrs
 281            (let ((fall-through (gensym)))
 282              `((let ((,fall-through (gen-label)))
 283                  ,@(gen-range-test temp (if not-p not-target target)
 284                                    fall-through nil
 285                                    0 1 (1- lowtag-limit) lowtags)
 286                  (emit-label ,fall-through))))
 287            (gen-range-test temp target not-target not-p 0 1
 288                            (1- lowtag-limit) lowtags)))
 289      (when hdrs
 290        `((inst cmpwi ,temp ,lowtag)
 291          (inst bne ,(if not-p target not-target))
 292          (load-type ,temp ,reg (- ,lowtag))
 293          ,@(gen-other-immediate-test temp target not-target not-p hdrs))))))
 294
 295 (defparameter immediate-types
 296   (list base-char-widetag unbound-marker-widetag))
 297
 298 (defparameter function-subtypes
 299   (list funcallable-instance-header-widetag
 300         simple-fun-header-widetag closure-fun-header-widetag
 301         closure-header-widetag))
 302
 303 (defmacro test-type (register temp target not-p &rest type-codes)
 304   (let* ((type-codes (mapcar #'eval type-codes))
 305          (lowtags (remove lowtag-limit type-codes :test #'<))
 306          (extended (remove lowtag-limit type-codes :test #'>))
 307          (immediates (intersection extended immediate-types :test #'eql))
 308          (headers (set-difference extended immediate-types :test #'eql))
 309          (function-p nil))
 310     (unless type-codes
 311       (error "Must supply at least on type for test-type."))
 312     (when (and headers (member other-pointer-lowtag lowtags))
 313       (warn "OTHER-POINTER-LOWTAG supersedes the use of ~S" headers)
 314       (setf headers nil))
 315     (when (and immediates
 316                (or (member other-immediate-0-lowtag lowtags)
 317                    (member other-immediate-1-lowtag lowtags)))
 318       (warn "OTHER-IMMEDIATE-n-LOWTAG supersedes the use of ~S" immediates)
 319       (setf immediates nil))
 320     (when (intersection headers function-subtypes)
 321       (unless (subsetp headers function-subtypes)
 322         (error "Can't test for mix of function subtypes and normal ~
 323                 header types."))
 324       (setq function-p t))
 325
 326     (let ((n-reg (gensym))
 327           (n-temp (gensym))
 328           (n-target (gensym))
 329           (not-target (gensym)))
 330       `(let ((,n-reg ,register)
 331              (,n-temp ,temp)
 332              (,n-target ,target)
 333              (,not-target (gen-label)))
 334          (declare (ignorable ,n-temp))
 335          ,@(if (constantp not-p)
 336                (test-type-aux n-reg n-temp n-target not-target
 337                               (eval not-p) lowtags immediates headers
 338                               function-p)
 339                `((cond (,not-p
 340                         ,@(test-type-aux n-reg n-temp n-target not-target t
 341                                          lowtags immediates headers
 342                                          function-p))
 343                        (t
 344                         ,@(test-type-aux n-reg n-temp n-target not-target nil
 345                                          lowtags immediates headers
 346                                          function-p)))))
 347          (emit-label ,not-target)))))
 348 |#
 349 \f
 350 ;;;; Error Code
 351
 352 (defvar *adjustable-vectors* nil)
 353
 354 (defmacro with-adjustable-vector ((var) &rest body)
 355   `(let ((,var (or (pop *adjustable-vectors*)
 356                    (make-array 16
 357                                :element-type '(unsigned-byte 8)
 358                                :fill-pointer 0
 359                                :adjustable t))))
 360      (declare (type (vector (unsigned-byte 8) 16) ,var))
 361      (setf (fill-pointer ,var) 0)
 362      (unwind-protect
 363          (progn
 364            ,@body)
 365        (push ,var *adjustable-vectors*))))
 366
 367 (eval-when (:compile-toplevel :load-toplevel :execute)
 368   (defun emit-error-break (vop kind code values)
 369     (let ((vector (gensym)))
 370       `((let ((vop ,vop))
 371           (when vop
 372             (note-this-location vop :internal-error)))
 373         (inst unimp ,kind)
 374         (with-adjustable-vector (,vector)
 375           (write-var-integer (error-number-or-lose ',code) ,vector)
 376           ,@(mapcar #'(lambda (tn)
 377                         `(let ((tn ,tn))
 378                            (write-var-integer (make-sc-offset (sc-number
 379                                                                (tn-sc tn))
 380                                                               (tn-offset tn))
 381                                               ,vector)))
 382                     values)
 383           (inst byte (length ,vector))
 384           (dotimes (i (length ,vector))
 385             (inst byte (aref ,vector i))))
 386         (align word-shift)))))
 387
 388 (defmacro error-call (vop error-code &rest values)
 389   "Cause an error.  ERROR-CODE is the error to cause."
 390   (cons 'progn
 391         (emit-error-break vop error-trap error-code values)))
 392
 393
 394 (defmacro cerror-call (vop label error-code &rest values)
 395   "Cause a continuable error.  If the error is continued, execution resumes at
 396   LABEL."
 397   `(progn
 398      ,@(emit-error-break vop cerror-trap error-code values)
 399      (inst b ,label)))
 400
 401 (defmacro generate-error-code (vop error-code &rest values)
 402   "Generate-Error-Code Error-code Value*
 403   Emit code for an error with the specified Error-Code and context Values."
 404   `(assemble (*elsewhere*)
 405      (let ((start-lab (gen-label)))
 406        (emit-label start-lab)
 407        (error-call ,vop ,error-code ,@values)
 408        start-lab)))
 409
 410 (defmacro generate-cerror-code (vop error-code &rest values)
 411   "Generate-CError-Code Error-code Value*
 412   Emit code for a continuable error with the specified Error-Code and
 413   context Values.  If the error is continued, execution resumes after
 414   the GENERATE-CERROR-CODE form."
 415   (let ((continue (gensym "CONTINUE-LABEL-"))
 416         (error (gensym "ERROR-LABEL-")))
 417     `(let ((,continue (gen-label)))
 418        (emit-label ,continue)
 419        (assemble (*elsewhere*)
 420          (let ((,error (gen-label)))
 421            (emit-label ,error)
 422            (cerror-call ,vop ,continue ,error-code ,@values)
 423            ,error)))))
 424
 425
 426 \f
 427 ;;; PSEUDO-ATOMIC -- Handy macro for making sequences look atomic.
 428 ;;;
 429 ;;; flag-tn must be wired to NL3. If a deferred interrupt happens
 430 ;;; while we have the low bits of alloc-tn set, we add a "large"
 431 ;;; constant to flag-tn.  On exit, we add flag-tn to alloc-tn
 432 ;;; which (a) aligns alloc-tn again and (b) makes alloc-tn go
 433 ;;; negative.  We then trap if alloc-tn's negative (handling the
 434 ;;; deferred interrupt) and using flag-tn - minus the large constant -
 435 ;;; to correct alloc-tn.
 436 (defmacro pseudo-atomic ((flag-tn &key (extra 0)) &rest forms)
 437   (let ((n-extra (gensym)))
 438     `(let ((,n-extra ,extra))
 439        (without-scheduling ()
 440         ;; Extra debugging stuff:
 441         #+debug
 442         (progn
 443           (inst andi. ,flag-tn alloc-tn 7)
 444           (inst twi :ne ,flag-tn 0))
 445         (inst lr ,flag-tn (- ,n-extra 4))
 446         (inst addi alloc-tn alloc-tn 4))
 447       ,@forms
 448       (without-scheduling ()
 449        (inst add alloc-tn alloc-tn ,flag-tn)
 450        (inst twi :lt alloc-tn 0))
 451       #+debug
 452       (progn
 453         (inst andi. ,flag-tn alloc-tn 7)
 454         (inst twi :ne ,flag-tn 0)))))
 455
 456
 457