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   (let* ((dlap-lambda-list (make-dlap-lambda-list metatypes applyp))
 108          (args (remove '&rest dlap-lambda-list))
 109          (restl (when applyp '(.lap-rest-arg.))))
 110     (generating-lisp '(emf)
 111                      dlap-lambda-list
 112                      `(invoke-effective-method-function emf
 113                                                         ,applyp
 114                                                         ,@args
 115                                                         ,@restl))))
 116
 117 ;;; --------------------------------
 118
 119 (defun generating-lisp (closure-variables args form)
 120   (let* ((rest (memq '&rest args))
 121          (ldiff (and rest (ldiff args rest)))
 122          (args (if rest (append ldiff '(&rest .lap-rest-arg.)) args))
 123          (lambda `(lambda ,closure-variables
 124                     ,@(when (member 'miss-fn closure-variables)
 125                         `((declare (type function miss-fn))))
 126                     #'(lambda ,args
 127                         (let ()
 128                           (declare #.*optimize-speed*)
 129                           ,form)))))
 130     (values (if *precompiling-lap*
 131                 `#',lambda
 132                 (compile nil lambda))
 133             nil)))
 134
 135 ;;; note on implementation for CMU 17 and later (including SBCL):
 136 ;;; Since STD-INSTANCE-P is weakened, that branch may run on non-PCL
 137 ;;; instances (structures). The result will be the non-wrapper layout
 138 ;;; for the structure, which will cause a miss. The "slots" will be
 139 ;;; whatever the first slot is, but will be ignored. Similarly,
 140 ;;; FSC-INSTANCE-P returns true on funcallable structures as well as
 141 ;;; PCL fins.
 142 (defun emit-reader/writer (reader/writer 1-or-2-class class-slot-p)
 143   (unless *optimize-cache-functions-p*
 144     (when (and (null *precompiling-lap*) *emit-function-p*)
 145       (return-from emit-reader/writer
 146         (emit-reader/writer-function
 147          reader/writer 1-or-2-class class-slot-p))))
 148   (let ((instance nil)
 149         (arglist  ())
 150         (closure-variables ())
 151         (field +first-wrapper-cache-number-index+)
 152         (read-form (emit-slot-read-form class-slot-p 'index 'slots)))
 153     ;;we need some field to do the fast obsolete check
 154     (ecase reader/writer
 155       ((:reader :boundp)
 156        (setq instance (dfun-arg-symbol 0)
 157              arglist  (list instance)))
 158       (:writer (setq instance (dfun-arg-symbol 1)
 159                      arglist  (list (dfun-arg-symbol 0) instance))))
 160     (ecase 1-or-2-class
 161       (1 (setq closure-variables '(wrapper-0 index miss-fn)))
 162       (2 (setq closure-variables '(wrapper-0 wrapper-1 index miss-fn))))
 163     (generating-lisp
 164      closure-variables
 165      arglist
 166      `(let* (,@(unless class-slot-p `((slots nil)))
 167                (wrapper (cond ((std-instance-p ,instance)
 168                                ,@(unless class-slot-p
 169                                    `((setq slots
 170                                            (std-instance-slots ,instance))))
 171                                (std-instance-wrapper ,instance))
 172                               ((fsc-instance-p ,instance)
 173                                ,@(unless class-slot-p
 174                                    `((setq slots
 175                                            (fsc-instance-slots ,instance))))
 176                                (fsc-instance-wrapper ,instance)))))
 177         (block access
 178           (when (and wrapper
 179                      (/= (wrapper-cache-number-vector-ref wrapper ,field) 0)
 180                      ,@(if (eql 1 1-or-2-class)
 181                            `((eq wrapper wrapper-0))
 182                            `((or (eq wrapper wrapper-0)
 183                                  (eq wrapper wrapper-1)))))
 184             ,@(ecase reader/writer
 185                 (:reader
 186                  `((let ((value ,read-form))
 187                      (unless (eq value +slot-unbound+)
 188                        (return-from access value)))))
 189                 (:boundp
 190                  `((let ((value ,read-form))
 191                       (return-from access (not (eq value +slot-unbound+))))))
 192                 (:writer
 193                  `((return-from access (setf ,read-form ,(car arglist)))))))
 194           (funcall miss-fn ,@arglist))))))
 195
 196 (defun emit-slot-read-form (class-slot-p index slots)
 197   (if class-slot-p
 198       `(cdr ,index)
 199       `(clos-slots-ref ,slots ,index)))
 200
 201 (defun emit-boundp-check (value-form miss-fn arglist)
 202   `(let ((value ,value-form))
 203      (if (eq value +slot-unbound+)
 204          (funcall ,miss-fn ,@arglist)
 205          value)))
 206
 207 (defun emit-slot-access (reader/writer class-slot-p slots
 208                          index miss-fn arglist)
 209   (let ((read-form (emit-slot-read-form class-slot-p index slots)))
 210     (ecase reader/writer
 211       (:reader (emit-boundp-check read-form miss-fn arglist))
 212       (:boundp `(not (eq ,read-form +slot-unbound+)))
 213       (:writer `(setf ,read-form ,(car arglist))))))
 214
 215 (defmacro emit-reader/writer-macro (reader/writer 1-or-2-class class-slot-p)
 216   (let ((*emit-function-p* nil)
 217         (*precompiling-lap* t))
 218     (values
 219      (emit-reader/writer reader/writer 1-or-2-class class-slot-p))))
 220
 221 (defun emit-one-or-n-index-reader/writer (reader/writer
 222                                           cached-index-p
 223                                           class-slot-p)
 224   (unless *optimize-cache-functions-p*
 225     (when (and (null *precompiling-lap*) *emit-function-p*)
 226       (return-from emit-one-or-n-index-reader/writer
 227         (emit-one-or-n-index-reader/writer-function
 228          reader/writer cached-index-p class-slot-p))))
 229   (multiple-value-bind (arglist metatypes)
 230       (ecase reader/writer
 231         ((:reader :boundp)
 232          (values (list (dfun-arg-symbol 0))
 233                  '(standard-instance)))
 234         (:writer (values (list (dfun-arg-symbol 0) (dfun-arg-symbol 1))
 235                          '(t standard-instance))))
 236     (generating-lisp
 237      `(cache ,@(unless cached-index-p '(index)) miss-fn)
 238      arglist
 239      `(let (,@(unless class-slot-p '(slots))
 240             ,@(when cached-index-p '(index)))
 241         ,(emit-dlap arglist metatypes
 242                     (emit-slot-access reader/writer class-slot-p
 243                                       'slots 'index 'miss-fn arglist)
 244                     `(funcall miss-fn ,@arglist)
 245                     (when cached-index-p 'index)
 246                     (unless class-slot-p '(slots)))))))
 247
 248 (defmacro emit-one-or-n-index-reader/writer-macro
 249     (reader/writer cached-index-p class-slot-p)
 250   (let ((*emit-function-p* nil)
 251         (*precompiling-lap* t))
 252     (values
 253      (emit-one-or-n-index-reader/writer reader/writer
 254                                         cached-index-p
 255                                         class-slot-p))))
 256
 257 (defun emit-miss (miss-fn args &optional applyp)
 258   (let ((restl (when applyp '(.lap-rest-arg.))))
 259     (if restl
 260         `(apply ,miss-fn ,@args ,@restl)
 261         `(funcall ,miss-fn ,@args ,@restl))))
 262
 263 (defun emit-checking-or-caching (cached-emf-p return-value-p metatypes applyp)
 264   (unless *optimize-cache-functions-p*
 265     (when (and (null *precompiling-lap*) *emit-function-p*)
 266       (return-from emit-checking-or-caching
 267         (emit-checking-or-caching-function
 268          cached-emf-p return-value-p metatypes applyp))))
 269   (let* ((dlap-lambda-list (make-dlap-lambda-list metatypes applyp))
 270          (args (remove '&rest dlap-lambda-list))
 271          (restl (when applyp '(.lap-rest-arg.))))
 272     (generating-lisp
 273      `(cache ,@(unless cached-emf-p '(emf)) miss-fn)
 274      dlap-lambda-list
 275      `(let (,@(when cached-emf-p '(emf)))
 276         ,(emit-dlap args
 277                     metatypes
 278                     (if return-value-p
 279                         (if cached-emf-p 'emf t)
 280                         `(invoke-effective-method-function
 281                           emf ,applyp ,@args ,@restl))
 282                     (emit-miss 'miss-fn args applyp)
 283                     (when cached-emf-p 'emf))))))
 284
 285 (defmacro emit-checking-or-caching-macro (cached-emf-p
 286                                           return-value-p
 287                                           metatypes
 288                                           applyp)
 289   (let ((*emit-function-p* nil)
 290         (*precompiling-lap* t))
 291     (values
 292      (emit-checking-or-caching cached-emf-p return-value-p metatypes applyp))))
 293
 294 (defun emit-dlap (args metatypes hit miss value-reg &optional slot-regs)
 295   (let* ((index -1)
 296          (wrapper-bindings (mapcan (lambda (arg mt)
 297                                      (unless (eq mt t)
 298                                        (incf index)
 299                                        `((,(format-symbol *pcl-package*
 300                                                           "WRAPPER-~D"
 301                                                           index)
 302                                           ,(emit-fetch-wrapper
 303                                             mt arg 'miss (pop slot-regs))))))
 304                                    args metatypes))
 305          (wrappers (mapcar #'car wrapper-bindings)))
 306     (declare (fixnum index))
 307     (unless wrappers (error "Every metatype is T."))
 308     `(block dfun
 309        (tagbody
 310           (let ((field (cache-field cache))
 311                 (cache-vector (cache-vector cache))
 312                 (mask (cache-mask cache))
 313                 (size (cache-size cache))
 314                 (overflow (cache-overflow cache))
 315                 ,@wrapper-bindings)
 316             (declare (fixnum size field mask))
 317             ,(cond ((cdr wrappers)
 318                     (emit-greater-than-1-dlap wrappers 'miss value-reg))
 319                    (value-reg
 320                     (emit-1-t-dlap (car wrappers) 'miss value-reg))
 321                    (t
 322                     (emit-1-nil-dlap (car wrappers) 'miss)))
 323             (return-from dfun ,hit))
 324         miss
 325           (return-from dfun ,miss)))))
 326
 327 (defun emit-1-nil-dlap (wrapper miss-label)
 328   `(let* ((primary ,(emit-1-wrapper-compute-primary-cache-location wrapper
 329                                                                    miss-label))
 330           (location primary))
 331      (declare (fixnum primary location))
 332      (block search
 333        (loop (when (eq ,wrapper (cache-vector-ref cache-vector location))
 334                (return-from search nil))
 335              (setq location (the fixnum (+ location 1)))
 336              (when (= location size)
 337                (setq location 0))
 338              (when (= location primary)
 339                (dolist (entry overflow)
 340                  (when (eq (car entry) ,wrapper)
 341                    (return-from search nil)))
 342                (go ,miss-label))))))
 343
 344 (defmacro get-cache-vector-lock-count (cache-vector)
 345   `(let ((lock-count (cache-vector-lock-count ,cache-vector)))
 346      (unless (typep lock-count 'fixnum)
 347        (error "My cache got freed somehow."))
 348      (the fixnum lock-count)))
 349
 350 (defun emit-1-t-dlap (wrapper miss-label value)
 351   `(let ((primary ,(emit-1-wrapper-compute-primary-cache-location wrapper
 352                                                                   miss-label))
 353          (initial-lock-count (get-cache-vector-lock-count cache-vector)))
 354      (declare (fixnum primary initial-lock-count))
 355      (let ((location primary))
 356        (declare (fixnum location))
 357        (block search
 358          (loop (when (eq ,wrapper (cache-vector-ref cache-vector location))
 359                  (setq ,value (cache-vector-ref cache-vector (1+ location)))
 360                  (return-from search nil))
 361                (setq location (the fixnum (+ location 2)))
 362                (when (= location size)
 363                  (setq location 0))
 364                (when (= location primary)
 365                  (dolist (entry overflow)
 366                    (when (eq (car entry) ,wrapper)
 367                      (setq ,value (cdr entry))
 368                      (return-from search nil)))
 369                  (go ,miss-label))))
 370        (unless (= initial-lock-count
 371                   (get-cache-vector-lock-count cache-vector))
 372          (go ,miss-label)))))
 373
 374 (defun emit-greater-than-1-dlap (wrappers miss-label value)
 375   (declare (type list wrappers))
 376   (let ((cache-line-size (compute-line-size (+ (length wrappers)
 377                                                (if value 1 0)))))
 378     `(let ((primary 0)
 379            (size-1 (the fixnum (- size 1))))
 380        (declare (fixnum primary size-1))
 381        ,(emit-n-wrapper-compute-primary-cache-location wrappers miss-label)
 382        (let ((initial-lock-count (get-cache-vector-lock-count cache-vector)))
 383          (declare (fixnum initial-lock-count))
 384          (let ((location primary)
 385                (next-location 0))
 386            (declare (fixnum location next-location))
 387            (block search
 388              (loop (setq next-location
 389                          (the fixnum (+ location ,cache-line-size)))
 390                    (when (and ,@(mapcar
 391                                  (lambda (wrapper)
 392                                    `(eq ,wrapper
 393                                         (cache-vector-ref
 394                                          cache-vector
 395                                          (setq location
 396                                                (the fixnum (+ location 1))))))
 397                                  wrappers))
 398                      ,@(when value
 399                          `((setq location (the fixnum (+ location 1)))
 400                            (setq ,value (cache-vector-ref cache-vector
 401                                                           location))))
 402                      (return-from search nil))
 403                    (setq location next-location)
 404                    (when (= location size-1)
 405                      (setq location 0))
 406                    (when (= location primary)
 407                      (dolist (entry overflow)
 408                        (let ((entry-wrappers (car entry)))
 409                          (when (and ,@(mapcar (lambda (wrapper)
 410                                                 `(eq ,wrapper
 411                                                      (pop entry-wrappers)))
 412                                               wrappers))
 413                            ,@(when value
 414                                `((setq ,value (cdr entry))))
 415                            (return-from search nil))))
 416                      (go ,miss-label))))
 417            (unless (= initial-lock-count
 418                       (get-cache-vector-lock-count cache-vector))
 419              (go ,miss-label)))))))
 420
 421 (defun emit-1-wrapper-compute-primary-cache-location (wrapper miss-label)
 422   `(let ((wrapper-cache-no (wrapper-cache-number-vector-ref ,wrapper field)))
 423      (declare (fixnum wrapper-cache-no))
 424      (when (zerop wrapper-cache-no) (go ,miss-label))
 425      ,(let ((form `(logand mask wrapper-cache-no)))
 426         `(the fixnum ,form))))
 427
 428 (defun emit-n-wrapper-compute-primary-cache-location (wrappers miss-label)
 429   (declare (type list wrappers))
 430   ;; This returns 1 less that the actual location.
 431   `(progn
 432      ,@(let ((adds 0) (len (length wrappers)))
 433          (declare (fixnum adds len))
 434          (mapcar (lambda (wrapper)
 435                    `(let ((wrapper-cache-no (wrapper-cache-number-vector-ref
 436                                              ,wrapper field)))
 437                       (declare (fixnum wrapper-cache-no))
 438                       (when (zerop wrapper-cache-no) (go ,miss-label))
 439                       (setq primary (the fixnum (+ primary wrapper-cache-no)))
 440                       ,@(progn
 441                           (incf adds)
 442                           (when (or (zerop (mod adds
 443                                                 wrapper-cache-number-adds-ok))
 444                                     (eql adds len))
 445                             `((setq primary
 446                                     ,(let ((form `(logand primary mask)))
 447                                        `(the fixnum ,form))))))))
 448                  wrappers))))
 449
 450 ;;; CMU17 (and SBCL) note: Since STD-INSTANCE-P is weakened in the
 451 ;;; CMU/SBCL approach of using funcallable instances, that branch may
 452 ;;; run on non-pcl instances (structures). The result will be the
 453 ;;; non-wrapper layout for the structure, which will cause a miss. The
 454 ;;; "slots" will be whatever the first slot is, but will be ignored.
 455 ;;; Similarly, FSC-INSTANCE-P returns true on funcallable structures
 456 ;;; as well as PCL fins.
 457 (defun emit-fetch-wrapper (metatype argument miss-label &optional slot)
 458   (ecase metatype
 459     ((standard-instance)
 460      `(cond ((std-instance-p ,argument)
 461              ,@(when slot `((setq ,slot (std-instance-slots ,argument))))
 462              (std-instance-wrapper ,argument))
 463             ((fsc-instance-p ,argument)
 464              ,@(when slot `((setq ,slot (fsc-instance-slots ,argument))))
 465              (fsc-instance-wrapper ,argument))
 466             (t
 467              (go ,miss-label))))
 468     (class
 469      (when slot (error "can't do a slot reg for this metatype"))
 470      `(wrapper-of-macro ,argument))
 471     ((built-in-instance structure-instance)
 472      (when slot (error "can't do a slot reg for this metatype"))
 473      `(built-in-or-structure-wrapper
 474        ,argument))))
 475