src/compiler/ppc/macros.lisp

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