src/pcl/dlisp.lisp

   1 ;;;; This software is part of the SBCL system. See the README file for
   2 ;;;; more information.
   3
   4 ;;;; This software is derived from software originally released by Xerox
   5 ;;;; Corporation. Copyright and release statements follow. Later modifications
   6 ;;;; to the software are in the public domain and are provided with
   7 ;;;; absolutely no warranty. See the COPYING and CREDITS files for more
   8 ;;;; information.
   9
  10 ;;;; copyright information from original PCL sources:
  11 ;;;;
  12 ;;;; Copyright (c) 1985, 1986, 1987, 1988, 1989, 1990 Xerox Corporation.
  13 ;;;; All rights reserved.
  14 ;;;;
  15 ;;;; Use and copying of this software and preparation of derivative works based
  16 ;;;; upon this software are permitted. Any distribution of this software or
  17 ;;;; derivative works must comply with all applicable United States export
  18 ;;;; control laws.
  19 ;;;;
  20 ;;;; This software is made available AS IS, and Xerox Corporation makes no
  21 ;;;; warranty about the software, its performance or its conformity to any
  22 ;;;; specification.
  23
  24 (in-package "SB-PCL")
  25 \f
  26 ;;; This file is (almost) functionally equivalent to dlap.lisp, but
  27 ;;; easier to read.
  28
  29 ;;; Might generate faster code, too, depending on the compiler and
  30 ;;; whether an implementation-specific lap assembler was used.
  31
  32 (defun emit-one-class-reader (class-slot-p)
  33   (emit-reader/writer :reader 1 class-slot-p))
  34
  35 (defun emit-one-class-boundp (class-slot-p)
  36   (emit-reader/writer :boundp 1 class-slot-p))
  37
  38 (defun emit-one-class-writer (class-slot-p)
  39   (emit-reader/writer :writer 1 class-slot-p))
  40
  41 (defun emit-two-class-reader (class-slot-p)
  42   (emit-reader/writer :reader 2 class-slot-p))
  43
  44 (defun emit-two-class-boundp (class-slot-p)
  45   (emit-reader/writer :boundp 2 class-slot-p))
  46
  47 (defun emit-two-class-writer (class-slot-p)
  48   (emit-reader/writer :writer 2 class-slot-p))
  49
  50 ;;; --------------------------------
  51
  52 (defun emit-one-index-readers (class-slot-p)
  53   (emit-one-or-n-index-reader/writer :reader nil class-slot-p))
  54
  55 (defun emit-one-index-boundps (class-slot-p)
  56   (emit-one-or-n-index-reader/writer :boundp nil class-slot-p))
  57
  58 (defun emit-one-index-writers (class-slot-p)
  59   (emit-one-or-n-index-reader/writer :writer nil class-slot-p))
  60
  61 (defun emit-n-n-readers ()
  62   (emit-one-or-n-index-reader/writer :reader t nil))
  63
  64 (defun emit-n-n-boundps ()
  65   (emit-one-or-n-index-reader/writer :boundp t nil))
  66
  67 (defun emit-n-n-writers ()
  68   (emit-one-or-n-index-reader/writer :writer t nil))
  69
  70 ;;; --------------------------------
  71
  72 (defun emit-checking (metatypes applyp)
  73   (emit-checking-or-caching nil nil metatypes applyp))
  74
  75 (defun emit-caching (metatypes applyp)
  76   (emit-checking-or-caching t nil metatypes applyp))
  77
  78 (defun emit-in-checking-cache-p (metatypes)
  79   (emit-checking-or-caching nil t metatypes nil))
  80
  81 (defun emit-constant-value (metatypes)
  82   (emit-checking-or-caching t t metatypes nil))
  83
  84 ;;; --------------------------------
  85
  86 ;;; FIXME: What do these variables mean?
  87 (defvar *precompiling-lap* nil)
  88 (defvar *emit-function-p* t)
  89
  90 ;;; FIXME: This variable is motivated by Gerd Moellman's observation,
  91 ;;; in <867kga1wra.fsf@gerd.free-bsd.org> on cmucl-imp 2002-10-22,
  92 ;;; that the functions returned from EMIT-xxx-FUNCTION can cause an
  93 ;;; order-of-magnitude slowdown.  We include this variable for now,
  94 ;;; but maybe its effect should rather be controlled by compilation
  95 ;;; policy if there is a noticeable space difference between the
  96 ;;; branches, or else maybe the EMIT-xxx-FUNCTION branches should be
  97 ;;; deleted.  It's not clear to me how all of this works, though, so
  98 ;;; until proper benchmarks are done it's probably safest simply to
  99 ;;; have this pseudo-constant to hide code.  -- CSR, 2003-02-14
 100 (defvar *optimize-cache-functions-p* t)
 101
 102 (defun emit-default-only (metatypes applyp)
 103   (unless *optimize-cache-functions-p*
 104     (when (and (null *precompiling-lap*) *emit-function-p*)
 105       (return-from emit-default-only
 106         (emit-default-only-function metatypes applyp))))
 107   (multiple-value-bind (lambda-list args rest-arg more-arg)
 108       (make-dlap-lambda-list metatypes applyp)
 109     (generating-lisp '(emf)
 110                      lambda-list
 111                      `(invoke-effective-method-function emf
 112                                                         ,applyp
 113                                                         :required-args ,args
 114                                                         :more-arg ,more-arg
 115                                                         :rest-arg ,rest-arg))))
 116
 117 ;;; --------------------------------
 118
 119 (defun generating-lisp (closure-variables args form)
 120   (let ((lambda `(lambda ,closure-variables
 121                    ,@(when (member 'miss-fn closure-variables)
 122                            `((declare (type function miss-fn))))
 123                    #'(lambda ,args
 124                        (let ()
 125                          (declare #.*optimize-speed*)
 126                          ,form)))))
 127     (values (if *precompiling-lap*
 128                 `#',lambda
 129                 (compile nil lambda))
 130             nil)))
 131
 132 ;;; note on implementation for CMU 17 and later (including SBCL):
 133 ;;; Since STD-INSTANCE-P is weakened, that branch may run on non-PCL
 134 ;;; instances (structures). The result will be the non-wrapper layout
 135 ;;; for the structure, which will cause a miss. The "slots" will be
 136 ;;; whatever the first slot is, but will be ignored. Similarly,
 137 ;;; FSC-INSTANCE-P returns true on funcallable structures as well as
 138 ;;; PCL fins.
 139 (defun emit-reader/writer (reader/writer 1-or-2-class class-slot-p)
 140   (unless *optimize-cache-functions-p*
 141     (when (and (null *precompiling-lap*) *emit-function-p*)
 142       (return-from emit-reader/writer
 143         (emit-reader/writer-function
 144          reader/writer 1-or-2-class class-slot-p))))
 145   (let ((instance nil)
 146         (arglist  ())
 147         (closure-variables ())
 148         (field +first-wrapper-cache-number-index+)
 149         (read-form (emit-slot-read-form class-slot-p 'index 'slots)))
 150     ;;we need some field to do the fast obsolete check
 151     (ecase reader/writer
 152       ((:reader :boundp)
 153        (setq instance (dfun-arg-symbol 0)
 154              arglist  (list instance)))
 155       (:writer (setq instance (dfun-arg-symbol 1)
 156                      arglist  (list (dfun-arg-symbol 0) instance))))
 157     (ecase 1-or-2-class
 158       (1 (setq closure-variables '(wrapper-0 index miss-fn)))
 159       (2 (setq closure-variables '(wrapper-0 wrapper-1 index miss-fn))))
 160     (generating-lisp
 161      closure-variables
 162      arglist
 163      `(let* (,@(unless class-slot-p `((slots nil)))
 164                (wrapper (cond ((std-instance-p ,instance)
 165                                ,@(unless class-slot-p
 166                                    `((setq slots
 167                                            (std-instance-slots ,instance))))
 168                                (std-instance-wrapper ,instance))
 169                               ((fsc-instance-p ,instance)
 170                                ,@(unless class-slot-p
 171                                    `((setq slots
 172                                            (fsc-instance-slots ,instance))))
 173                                (fsc-instance-wrapper ,instance)))))
 174         (block access
 175           (when (and wrapper
 176                      (/= (wrapper-cache-number-vector-ref wrapper ,field) 0)
 177                      ,@(if (eql 1 1-or-2-class)
 178                            `((eq wrapper wrapper-0))
 179                            `((or (eq wrapper wrapper-0)
 180                                  (eq wrapper wrapper-1)))))
 181             ,@(ecase reader/writer
 182                 (:reader
 183                  `((let ((value ,read-form))
 184                      (unless (eq value +slot-unbound+)
 185                        (return-from access value)))))
 186                 (:boundp
 187                  `((let ((value ,read-form))
 188                       (return-from access (not (eq value +slot-unbound+))))))
 189                 (:writer
 190                  `((return-from access (setf ,read-form ,(car arglist)))))))
 191           (funcall miss-fn ,@arglist))))))
 192
 193 (defun emit-slot-read-form (class-slot-p index slots)
 194   (if class-slot-p
 195       `(cdr ,index)
 196       `(clos-slots-ref ,slots ,index)))
 197
 198 (defun emit-boundp-check (value-form miss-fn arglist)
 199   `(let ((value ,value-form))
 200      (if (eq value +slot-unbound+)
 201          (funcall ,miss-fn ,@arglist)
 202          value)))
 203
 204 (defun emit-slot-access (reader/writer class-slot-p slots
 205                          index miss-fn arglist)
 206   (let ((read-form (emit-slot-read-form class-slot-p index slots)))
 207     (ecase reader/writer
 208       (:reader (emit-boundp-check read-form miss-fn arglist))
 209       (:boundp `(not (eq ,read-form +slot-unbound+)))
 210       (:writer `(setf ,read-form ,(car arglist))))))
 211
 212 (defmacro emit-reader/writer-macro (reader/writer 1-or-2-class class-slot-p)
 213   (let ((*emit-function-p* nil)
 214         (*precompiling-lap* t))
 215     (values
 216      (emit-reader/writer reader/writer 1-or-2-class class-slot-p))))
 217
 218 (defun emit-one-or-n-index-reader/writer (reader/writer
 219                                           cached-index-p
 220                                           class-slot-p)
 221   (unless *optimize-cache-functions-p*
 222     (when (and (null *precompiling-lap*) *emit-function-p*)
 223       (return-from emit-one-or-n-index-reader/writer
 224         (emit-one-or-n-index-reader/writer-function
 225          reader/writer cached-index-p class-slot-p))))
 226   (multiple-value-bind (arglist metatypes)
 227       (ecase reader/writer
 228         ((:reader :boundp)
 229          (values (list (dfun-arg-symbol 0))
 230                  '(standard-instance)))
 231         (:writer (values (list (dfun-arg-symbol 0) (dfun-arg-symbol 1))
 232                          '(t standard-instance))))
 233     (generating-lisp
 234      `(cache ,@(unless cached-index-p '(index)) miss-fn)
 235      arglist
 236      `(let (,@(unless class-slot-p '(slots))
 237             ,@(when cached-index-p '(index)))
 238         ,(emit-dlap arglist metatypes
 239                     (emit-slot-access reader/writer class-slot-p
 240                                       'slots 'index 'miss-fn arglist)
 241                     `(funcall miss-fn ,@arglist)
 242                     (when cached-index-p 'index)
 243                     (unless class-slot-p '(slots)))))))
 244
 245 (defmacro emit-one-or-n-index-reader/writer-macro
 246     (reader/writer cached-index-p class-slot-p)
 247   (let ((*emit-function-p* nil)
 248         (*precompiling-lap* t))
 249     (values
 250      (emit-one-or-n-index-reader/writer reader/writer
 251                                         cached-index-p
 252                                         class-slot-p))))
 253
 254 (defun emit-miss (miss-fn args applyp)
 255   (if applyp
 256       `(multiple-value-call ,miss-fn ,@args
 257                             (sb-c::%more-arg-values .more-context.
 258                                                     0
 259                                                     .more-count.))
 260       `(funcall ,miss-fn ,@args)))
 261
 262 (defun emit-checking-or-caching (cached-emf-p return-value-p metatypes applyp)
 263   (unless *optimize-cache-functions-p*
 264     (when (and (null *precompiling-lap*) *emit-function-p*)
 265       (return-from emit-checking-or-caching
 266         (emit-checking-or-caching-function
 267          cached-emf-p return-value-p metatypes applyp))))
 268   (multiple-value-bind (lambda-list args rest-arg more-arg)
 269       (make-dlap-lambda-list metatypes applyp)
 270     (generating-lisp
 271      `(cache ,@(unless cached-emf-p '(emf)) miss-fn)
 272      lambda-list
 273      `(let (,@(when cached-emf-p '(emf)))
 274         ,(emit-dlap args
 275                     metatypes
 276                     (if return-value-p
 277                         (if cached-emf-p 'emf t)
 278                         `(invoke-effective-method-function
 279                           emf ,applyp
 280                           :required-args ,args
 281                           :more-arg ,more-arg
 282                           :rest-arg ,rest-arg))
 283                     (emit-miss 'miss-fn args applyp)
 284                     (when cached-emf-p 'emf))))))
 285
 286 (defmacro emit-checking-or-caching-macro (cached-emf-p
 287                                           return-value-p
 288                                           metatypes
 289                                           applyp)
 290   (let ((*emit-function-p* nil)
 291         (*precompiling-lap* t))
 292     (values
 293      (emit-checking-or-caching cached-emf-p return-value-p metatypes applyp))))
 294
 295 (defun emit-dlap (args metatypes hit miss value-reg &optional slot-regs)
 296   (let* ((index -1)
 297          (wrapper-bindings (mapcan (lambda (arg mt)
 298                                      (unless (eq mt t)
 299                                        (incf index)
 300                                        `((,(format-symbol *pcl-package*
 301                                                           "WRAPPER-~D"
 302                                                           index)
 303                                           ,(emit-fetch-wrapper
 304                                             mt arg 'miss (pop slot-regs))))))
 305                                    args metatypes))
 306          (wrappers (mapcar #'car wrapper-bindings)))
 307     (declare (fixnum index))
 308     (unless wrappers (error "Every metatype is T."))
 309     `(block dfun
 310        (tagbody
 311           (let ((field (cache-field cache))
 312                 (cache-vector (cache-vector cache))
 313                 (mask (cache-mask cache))
 314                 (size (cache-size cache))
 315                 (overflow (cache-overflow cache))
 316                 ,@wrapper-bindings)
 317             (declare (fixnum size field mask))
 318             ,(cond ((cdr wrappers)
 319                     (emit-greater-than-1-dlap wrappers 'miss value-reg))
 320                    (value-reg
 321                     (emit-1-t-dlap (car wrappers) 'miss value-reg))
 322                    (t
 323                     (emit-1-nil-dlap (car wrappers) 'miss)))
 324             (return-from dfun ,hit))
 325         miss
 326           (return-from dfun ,miss)))))
 327
 328 (defun emit-1-nil-dlap (wrapper miss-label)
 329   `(let* ((primary ,(emit-1-wrapper-compute-primary-cache-location wrapper
 330                                                                    miss-label))
 331           (location primary))
 332      (declare (fixnum primary location))
 333      (block search
 334        (loop (when (eq ,wrapper (cache-vector-ref cache-vector location))
 335                (return-from search nil))
 336              (setq location (the fixnum (+ location 1)))
 337              (when (= location size)
 338                (setq location 0))
 339              (when (= location primary)
 340                (dolist (entry overflow)
 341                  (when (eq (car entry) ,wrapper)
 342                    (return-from search nil)))
 343                (go ,miss-label))))))
 344
 345 (defmacro get-cache-vector-lock-count (cache-vector)
 346   `(let ((lock-count (cache-vector-lock-count ,cache-vector)))
 347      (unless (typep lock-count 'fixnum)
 348        (error "My cache got freed somehow."))
 349      (the fixnum lock-count)))
 350
 351 (defun emit-1-t-dlap (wrapper miss-label value)
 352   `(let ((primary ,(emit-1-wrapper-compute-primary-cache-location wrapper
 353                                                                   miss-label))
 354          (initial-lock-count (get-cache-vector-lock-count cache-vector)))
 355      (declare (fixnum primary initial-lock-count))
 356      (let ((location primary))
 357        (declare (fixnum location))
 358        (block search
 359          (loop (when (eq ,wrapper (cache-vector-ref cache-vector location))
 360                  (setq ,value (cache-vector-ref cache-vector (1+ location)))
 361                  (return-from search nil))
 362                (setq location (the fixnum (+ location 2)))
 363                (when (= location size)
 364                  (setq location 0))
 365                (when (= location primary)
 366                  (dolist (entry overflow)
 367                    (when (eq (car entry) ,wrapper)
 368                      (setq ,value (cdr entry))
 369                      (return-from search nil)))
 370                  (go ,miss-label))))
 371        (unless (= initial-lock-count
 372                   (get-cache-vector-lock-count cache-vector))
 373          (go ,miss-label)))))
 374
 375 (defun emit-greater-than-1-dlap (wrappers miss-label value)
 376   (declare (type list wrappers))
 377   (let ((cache-line-size (compute-line-size (+ (length wrappers)
 378                                                (if value 1 0)))))
 379     `(let ((primary 0)
 380            (size-1 (the fixnum (- size 1))))
 381        (declare (fixnum primary size-1))
 382        ,(emit-n-wrapper-compute-primary-cache-location wrappers miss-label)
 383        (let ((initial-lock-count (get-cache-vector-lock-count cache-vector)))
 384          (declare (fixnum initial-lock-count))
 385          (let ((location primary)
 386                (next-location 0))
 387            (declare (fixnum location next-location))
 388            (block search
 389              (loop (setq next-location
 390                          (the fixnum (+ location ,cache-line-size)))
 391                    (when (and ,@(mapcar
 392                                  (lambda (wrapper)
 393                                    `(eq ,wrapper
 394                                         (cache-vector-ref
 395                                          cache-vector
 396                                          (setq location
 397                                                (the fixnum (+ location 1))))))
 398                                  wrappers))
 399                      ,@(when value
 400                          `((setq location (the fixnum (+ location 1)))
 401                            (setq ,value (cache-vector-ref cache-vector
 402                                                           location))))
 403                      (return-from search nil))
 404                    (setq location next-location)
 405                    (when (= location size-1)
 406                      (setq location 0))
 407                    (when (= location primary)
 408                      (dolist (entry overflow)
 409                        (let ((entry-wrappers (car entry)))
 410                          (when (and ,@(mapcar (lambda (wrapper)
 411                                                 `(eq ,wrapper
 412                                                      (pop entry-wrappers)))
 413                                               wrappers))
 414                            ,@(when value
 415                                `((setq ,value (cdr entry))))
 416                            (return-from search nil))))
 417                      (go ,miss-label))))
 418            (unless (= initial-lock-count
 419                       (get-cache-vector-lock-count cache-vector))
 420              (go ,miss-label)))))))
 421
 422 (defun emit-1-wrapper-compute-primary-cache-location (wrapper miss-label)
 423   `(let ((wrapper-cache-no (wrapper-cache-number-vector-ref ,wrapper field)))
 424      (declare (fixnum wrapper-cache-no))
 425      (when (zerop wrapper-cache-no) (go ,miss-label))
 426      ,(let ((form `(logand mask wrapper-cache-no)))
 427         `(the fixnum ,form))))
 428
 429 (defun emit-n-wrapper-compute-primary-cache-location (wrappers miss-label)
 430   (declare (type list wrappers))
 431   ;; This returns 1 less that the actual location.
 432   `(progn
 433      ,@(let ((adds 0) (len (length wrappers)))
 434          (declare (fixnum adds len))
 435          (mapcar (lambda (wrapper)
 436                    `(let ((wrapper-cache-no (wrapper-cache-number-vector-ref
 437                                              ,wrapper field)))
 438                       (declare (fixnum wrapper-cache-no))
 439                       (when (zerop wrapper-cache-no) (go ,miss-label))
 440                       (setq primary (the fixnum (+ primary wrapper-cache-no)))
 441                       ,@(progn
 442                           (incf adds)
 443                           (when (or (zerop (mod adds
 444                                                 wrapper-cache-number-adds-ok))
 445                                     (eql adds len))
 446                             `((setq primary
 447                                     ,(let ((form `(logand primary mask)))
 448                                        `(the fixnum ,form))))))))
 449                  wrappers))))
 450
 451 ;;; CMU17 (and SBCL) note: Since STD-INSTANCE-P is weakened in the
 452 ;;; CMU/SBCL approach of using funcallable instances, that branch may
 453 ;;; run on non-pcl instances (structures). The result will be the
 454 ;;; non-wrapper layout for the structure, which will cause a miss. The
 455 ;;; "slots" will be whatever the first slot is, but will be ignored.
 456 ;;; Similarly, FSC-INSTANCE-P returns true on funcallable structures
 457 ;;; as well as PCL fins.
 458 (defun emit-fetch-wrapper (metatype argument miss-label &optional slot)
 459   (ecase metatype
 460     ((standard-instance)
 461      `(cond ((std-instance-p ,argument)
 462              ,@(when slot `((setq ,slot (std-instance-slots ,argument))))
 463              (std-instance-wrapper ,argument))
 464             ((fsc-instance-p ,argument)
 465              ,@(when slot `((setq ,slot (fsc-instance-slots ,argument))))
 466              (fsc-instance-wrapper ,argument))
 467             (t
 468              (go ,miss-label))))
 469     (class
 470      (when slot (error "can't do a slot reg for this metatype"))
 471      `(wrapper-of ,argument))
 472     ((built-in-instance structure-instance)
 473      (when slot (error "can't do a slot reg for this metatype"))
 474      `(built-in-or-structure-wrapper
 475        ,argument))))
 476