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 easier to
  27 ;;; read.
  28
  29 ;;; Might generate faster code, too, depending on the compiler and whether an
  30 ;;; 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-writer (class-slot-p)
  36   (emit-reader/writer :writer 1 class-slot-p))
  37
  38 (defun emit-two-class-reader (class-slot-p)
  39   (emit-reader/writer :reader 2 class-slot-p))
  40
  41 (defun emit-two-class-writer (class-slot-p)
  42   (emit-reader/writer :writer 2 class-slot-p))
  43
  44 ;;; --------------------------------
  45
  46 (defun emit-one-index-readers (class-slot-p)
  47   (emit-one-or-n-index-reader/writer :reader nil class-slot-p))
  48
  49 (defun emit-one-index-writers (class-slot-p)
  50   (emit-one-or-n-index-reader/writer :writer nil class-slot-p))
  51
  52 (defun emit-n-n-readers ()
  53   (emit-one-or-n-index-reader/writer :reader t nil))
  54
  55 (defun emit-n-n-writers ()
  56   (emit-one-or-n-index-reader/writer :writer t nil))
  57
  58 ;;; --------------------------------
  59
  60 (defun emit-checking (metatypes applyp)
  61   (emit-checking-or-caching nil nil metatypes applyp))
  62
  63 (defun emit-caching (metatypes applyp)
  64   (emit-checking-or-caching t nil metatypes applyp))
  65
  66 (defun emit-in-checking-cache-p (metatypes)
  67   (emit-checking-or-caching nil t metatypes nil))
  68
  69 (defun emit-constant-value (metatypes)
  70   (emit-checking-or-caching t t metatypes nil))
  71
  72 ;;; --------------------------------
  73
  74 (defvar *precompiling-lap* nil)
  75 (defvar *emit-function-p* t)
  76
  77 (defun emit-default-only (metatypes applyp)
  78   (when (and (null *precompiling-lap*) *emit-function-p*)
  79     (return-from emit-default-only
  80       (emit-default-only-function metatypes applyp)))
  81   (let* ((dlap-lambda-list (make-dlap-lambda-list metatypes applyp))
  82          (args (remove '&rest dlap-lambda-list))
  83          (restl (when applyp '(.lap-rest-arg.))))
  84     (generating-lisp '(emf)
  85                      dlap-lambda-list
  86       `(invoke-effective-method-function emf ,applyp ,@args ,@restl))))
  87
  88 (defmacro emit-default-only-macro (metatypes applyp)
  89   (let ((*emit-function-p* nil)
  90         (*precompiling-lap* t))
  91     (values
  92      (emit-default-only metatypes applyp))))
  93
  94 ;;; --------------------------------
  95
  96 (defun generating-lisp (closure-variables args form)
  97   (let* ((rest (memq '&rest args))
  98          (ldiff (and rest (ldiff args rest)))
  99          (args (if rest (append ldiff '(&rest .lap-rest-arg.)) args))
 100          (lambda `(lambda ,closure-variables
 101                     ,@(when (member 'miss-fn closure-variables)
 102                         `((declare (type function miss-fn))))
 103                     #'(sb-kernel:instance-lambda ,args
 104                         (let ()
 105                           (declare #.*optimize-speed*)
 106                           ,form)))))
 107     (values (if *precompiling-lap*
 108                 `#',lambda
 109                 (compile nil lambda))
 110             nil)))
 111
 112 ;;; note on implementation for CMU 17 and later (including SBCL):
 113 ;;; Since std-instance-p is weakened, that branch may run on non-pcl
 114 ;;; instances (structures). The result will be the non-wrapper layout
 115 ;;; for the structure, which will cause a miss. The "slots" will be
 116 ;;; whatever the first slot is, but will be ignored. Similarly,
 117 ;;; fsc-instance-p returns true on funcallable structures as well as
 118 ;;; PCL fins.
 119 (defun emit-reader/writer (reader/writer 1-or-2-class class-slot-p)
 120   (when (and (null *precompiling-lap*) *emit-function-p*)
 121     (return-from emit-reader/writer
 122       (emit-reader/writer-function reader/writer 1-or-2-class class-slot-p)))
 123   (let ((instance nil)
 124         (arglist  ())
 125         (closure-variables ())
 126         (field (first-wrapper-cache-number-index))
 127         (readp (eq reader/writer :reader))
 128         (read-form (emit-slot-read-form class-slot-p 'index 'slots)))
 129     ;;we need some field to do the fast obsolete check
 130     (ecase reader/writer
 131       (:reader (setq instance (dfun-arg-symbol 0)
 132                      arglist  (list instance)))
 133       (:writer (setq instance (dfun-arg-symbol 1)
 134                      arglist  (list (dfun-arg-symbol 0) instance))))
 135     (ecase 1-or-2-class
 136       (1 (setq closure-variables '(wrapper-0 index miss-fn)))
 137       (2 (setq closure-variables '(wrapper-0 wrapper-1 index miss-fn))))
 138     (generating-lisp closure-variables
 139                      arglist
 140        `(let* (,@(unless class-slot-p `((slots nil)))
 141                (wrapper (cond ((std-instance-p ,instance)
 142                                ,@(unless class-slot-p
 143                                    `((setq slots (std-instance-slots ,instance))))
 144                                (std-instance-wrapper ,instance))
 145                               ((fsc-instance-p ,instance)
 146                                ,@(unless class-slot-p
 147                                    `((setq slots (fsc-instance-slots ,instance))))
 148                                (fsc-instance-wrapper ,instance)))))
 149           (block access
 150             (when (and wrapper
 151                        (/= (wrapper-cache-number-vector-ref wrapper ,field) 0)
 152                        ,@(if (eql 1 1-or-2-class)
 153                              `((eq wrapper wrapper-0))
 154                              `((or (eq wrapper wrapper-0)
 155                                    (eq wrapper wrapper-1)))))
 156               ,@(if readp
 157                     `((let ((value ,read-form))
 158                         (unless (eq value +slot-unbound+)
 159                           (return-from access value))))
 160                     `((return-from access (setf ,read-form ,(car arglist))))))
 161             (funcall miss-fn ,@arglist))))))
 162
 163 (defun emit-slot-read-form (class-slot-p index slots)
 164   (if class-slot-p
 165       `(cdr ,index)
 166       `(instance-ref ,slots ,index)))
 167
 168 (defun emit-slot-write-form (class-slot-p index slots value)
 169   (if class-slot-p
 170       `(setf (cdr ,index) ,value)
 171       `(and ,slots (setf (instance-ref ,slots ,index) ,value))))
 172
 173 (defun emit-boundp-check (value-form miss-fn arglist)
 174   `(let ((value ,value-form))
 175      (if (eq value +slot-unbound+)
 176          (funcall ,miss-fn ,@arglist)
 177          value)))
 178
 179 (defun emit-slot-access (reader/writer class-slot-p slots index miss-fn arglist)
 180   (let ((read-form (emit-slot-read-form class-slot-p index slots))
 181         (write-form (emit-slot-write-form
 182                      class-slot-p index slots (car arglist))))
 183     (ecase reader/writer
 184       (:reader (emit-boundp-check read-form miss-fn arglist))
 185       (:writer write-form))))
 186
 187 (defmacro emit-reader/writer-macro (reader/writer 1-or-2-class class-slot-p)
 188   (let ((*emit-function-p* nil)
 189         (*precompiling-lap* t))
 190     (values
 191      (emit-reader/writer reader/writer 1-or-2-class class-slot-p))))
 192
 193 (defun emit-one-or-n-index-reader/writer (reader/writer cached-index-p class-slot-p)
 194   (when (and (null *precompiling-lap*) *emit-function-p*)
 195     (return-from emit-one-or-n-index-reader/writer
 196       (emit-one-or-n-index-reader/writer-function
 197        reader/writer cached-index-p class-slot-p)))
 198   (multiple-value-bind (arglist metatypes)
 199       (ecase reader/writer
 200         (:reader (values (list (dfun-arg-symbol 0))
 201                          '(standard-instance)))
 202         (:writer (values (list (dfun-arg-symbol 0) (dfun-arg-symbol 1))
 203                          '(t standard-instance))))
 204     (generating-lisp `(cache ,@(unless cached-index-p '(index)) miss-fn)
 205                      arglist
 206       `(let (,@(unless class-slot-p '(slots))
 207              ,@(when cached-index-p '(index)))
 208          ,(emit-dlap arglist metatypes
 209                      (emit-slot-access reader/writer class-slot-p
 210                                        'slots 'index 'miss-fn arglist)
 211                      `(funcall miss-fn ,@arglist)
 212                      (when cached-index-p 'index)
 213                      (unless class-slot-p '(slots)))))))
 214
 215 (defmacro emit-one-or-n-index-reader/writer-macro
 216     (reader/writer cached-index-p class-slot-p)
 217   (let ((*emit-function-p* nil)
 218         (*precompiling-lap* t))
 219     (values
 220      (emit-one-or-n-index-reader/writer reader/writer cached-index-p class-slot-p))))
 221
 222 (defun emit-miss (miss-fn args &optional applyp)
 223   (let ((restl (when applyp '(.lap-rest-arg.))))
 224     (if restl
 225         `(apply ,miss-fn ,@args ,@restl)
 226         `(funcall ,miss-fn ,@args ,@restl))))
 227
 228 (defun emit-checking-or-caching (cached-emf-p return-value-p metatypes applyp)
 229   (when (and (null *precompiling-lap*) *emit-function-p*)
 230     (return-from emit-checking-or-caching
 231       (emit-checking-or-caching-function
 232        cached-emf-p return-value-p metatypes applyp)))
 233   (let* ((dlap-lambda-list (make-dlap-lambda-list metatypes applyp))
 234          (args (remove '&rest dlap-lambda-list))
 235          (restl (when applyp '(.lap-rest-arg.))))
 236     (generating-lisp `(cache ,@(unless cached-emf-p '(emf)) miss-fn)
 237                      dlap-lambda-list
 238       `(let (,@(when cached-emf-p '(emf)))
 239          ,(emit-dlap args
 240                      metatypes
 241                      (if return-value-p
 242                          (if cached-emf-p 'emf t)
 243                          `(invoke-effective-method-function emf ,applyp
 244                            ,@args ,@restl))
 245                      (emit-miss 'miss-fn args applyp)
 246                      (when cached-emf-p 'emf))))))
 247
 248 (defmacro emit-checking-or-caching-macro (cached-emf-p return-value-p metatypes applyp)
 249   (let ((*emit-function-p* nil)
 250         (*precompiling-lap* t))
 251     (values
 252      (emit-checking-or-caching cached-emf-p return-value-p metatypes applyp))))
 253
 254 (defun emit-dlap (args metatypes hit miss value-reg &optional slot-regs)
 255   (let* ((index -1)
 256          (wrapper-bindings (mapcan #'(lambda (arg mt)
 257                                        (unless (eq mt 't)
 258                                          (incf index)
 259                                          `((,(intern (format nil
 260                                                              "WRAPPER-~D"
 261                                                              index)
 262                                                      *pcl-package*)
 263                                             ,(emit-fetch-wrapper mt arg 'miss
 264                                               (pop slot-regs))))))
 265                                    args metatypes))
 266          (wrappers (mapcar #'car wrapper-bindings)))
 267     (declare (fixnum index))
 268     (unless wrappers (error "Every metatype is T."))
 269     `(block dfun
 270        (tagbody
 271           (let ((field (cache-field cache))
 272                 (cache-vector (cache-vector cache))
 273                 (mask (cache-mask cache))
 274                 (size (cache-size cache))
 275                 (overflow (cache-overflow cache))
 276                 ,@wrapper-bindings)
 277             (declare (fixnum size field mask))
 278             ,(cond ((cdr wrappers)
 279                     (emit-greater-than-1-dlap wrappers 'miss value-reg))
 280                    (value-reg
 281                     (emit-1-t-dlap (car wrappers) 'miss value-reg))
 282                    (t
 283                     (emit-1-nil-dlap (car wrappers) 'miss)))
 284             (return-from dfun ,hit))
 285         miss
 286           (return-from dfun ,miss)))))
 287
 288 (defun emit-1-nil-dlap (wrapper miss-label)
 289   `(let* ((primary ,(emit-1-wrapper-compute-primary-cache-location wrapper miss-label))
 290           (location primary))
 291      (declare (fixnum primary location))
 292      (block search
 293        (loop (when (eq ,wrapper (cache-vector-ref cache-vector location))
 294                (return-from search nil))
 295              (setq location (the fixnum (+ location 1)))
 296              (when (= location size)
 297                (setq location 0))
 298              (when (= location primary)
 299                (dolist (entry overflow)
 300                  (when (eq (car entry) ,wrapper)
 301                    (return-from search nil)))
 302                (go ,miss-label))))))
 303
 304 (defmacro get-cache-vector-lock-count (cache-vector)
 305   `(let ((lock-count (cache-vector-lock-count ,cache-vector)))
 306      (unless (typep lock-count 'fixnum)
 307        (error "My cache got freed somehow."))
 308      (the fixnum lock-count)))
 309
 310 (defun emit-1-t-dlap (wrapper miss-label value)
 311   `(let ((primary ,(emit-1-wrapper-compute-primary-cache-location wrapper miss-label))
 312          (initial-lock-count (get-cache-vector-lock-count cache-vector)))
 313      (declare (fixnum primary initial-lock-count))
 314      (let ((location primary))
 315        (declare (fixnum location))
 316        (block search
 317          (loop (when (eq ,wrapper (cache-vector-ref cache-vector location))
 318                  (setq ,value (cache-vector-ref cache-vector (1+ location)))
 319                  (return-from search nil))
 320                (setq location (the fixnum (+ location 2)))
 321                (when (= location size)
 322                  (setq location 0))
 323                (when (= location primary)
 324                  (dolist (entry overflow)
 325                    (when (eq (car entry) ,wrapper)
 326                      (setq ,value (cdr entry))
 327                      (return-from search nil)))
 328                  (go ,miss-label))))
 329        (unless (= initial-lock-count
 330                   (get-cache-vector-lock-count cache-vector))
 331          (go ,miss-label)))))
 332
 333 (defun emit-greater-than-1-dlap (wrappers miss-label value)
 334   (declare (type list wrappers))
 335   (let ((cache-line-size (compute-line-size (+ (length wrappers) (if value 1 0)))))
 336     `(let ((primary 0) (size-1 (the fixnum (- size 1))))
 337        (declare (fixnum primary size-1))
 338        ,(emit-n-wrapper-compute-primary-cache-location wrappers miss-label)
 339        (let ((initial-lock-count (get-cache-vector-lock-count cache-vector)))
 340          (declare (fixnum initial-lock-count))
 341          (let ((location primary) (next-location 0))
 342            (declare (fixnum location next-location))
 343            (block search
 344              (loop (setq next-location (the fixnum (+ location ,cache-line-size)))
 345                    (when (and ,@(mapcar
 346                                  #'(lambda (wrapper)
 347                                      `(eq ,wrapper
 348                                        (cache-vector-ref cache-vector
 349                                         (setq location
 350                                          (the fixnum (+ location 1))))))
 351                                  wrappers))
 352                      ,@(when value
 353                          `((setq location (the fixnum (+ location 1)))
 354                            (setq ,value (cache-vector-ref cache-vector location))))
 355                      (return-from search nil))
 356                    (setq location next-location)
 357                    (when (= location size-1)
 358                      (setq location 0))
 359                    (when (= location primary)
 360                      (dolist (entry overflow)
 361                        (let ((entry-wrappers (car entry)))
 362                          (when (and ,@(mapcar #'(lambda (wrapper)
 363                                                   `(eq ,wrapper (pop entry-wrappers)))
 364                                               wrappers))
 365                            ,@(when value
 366                                `((setq ,value (cdr entry))))
 367                            (return-from search nil))))
 368                      (go ,miss-label))))
 369            (unless (= initial-lock-count
 370                       (get-cache-vector-lock-count cache-vector))
 371              (go ,miss-label)))))))
 372
 373 (defun emit-1-wrapper-compute-primary-cache-location (wrapper miss-label)
 374   `(let ((wrapper-cache-no (wrapper-cache-number-vector-ref ,wrapper field)))
 375      (declare (fixnum wrapper-cache-no))
 376      (when (zerop wrapper-cache-no) (go ,miss-label))
 377      ,(let ((form `(logand mask wrapper-cache-no)))
 378         `(the fixnum ,form))))
 379
 380 (defun emit-n-wrapper-compute-primary-cache-location (wrappers miss-label)
 381   (declare (type list wrappers))
 382   ;; This returns 1 less that the actual location.
 383   `(progn
 384      ,@(let ((adds 0) (len (length wrappers)))
 385          (declare (fixnum adds len))
 386          (mapcar #'(lambda (wrapper)
 387                      `(let ((wrapper-cache-no (wrapper-cache-number-vector-ref
 388                                                ,wrapper field)))
 389                         (declare (fixnum wrapper-cache-no))
 390                         (when (zerop wrapper-cache-no) (go ,miss-label))
 391                         (setq primary (the fixnum (+ primary wrapper-cache-no)))
 392                         ,@(progn
 393                             (incf adds)
 394                             (when (or (zerop (mod adds wrapper-cache-number-adds-ok))
 395                                       (eql adds len))
 396                               `((setq primary
 397                                       ,(let ((form `(logand primary mask)))
 398                                          `(the fixnum ,form))))))))
 399                  wrappers))))
 400
 401 ;;; CMU17 (and SBCL) note: Since STD-INSTANCE-P is weakened in the CMU/SBCL
 402 ;;; approach of using funcallable instances, that branch may run
 403 ;;; on non-pcl instances (structures). The result will be the
 404 ;;; non-wrapper layout for the structure, which will cause a miss. The "slots"
 405 ;;; will be whatever the first slot is, but will be ignored. Similarly,
 406 ;;; fsc-instance-p returns true on funcallable structures as well as PCL fins.
 407 (defun emit-fetch-wrapper (metatype argument miss-label &optional slot)
 408   (ecase metatype
 409     ((standard-instance)
 410      `(cond ((std-instance-p ,argument)
 411              ,@(when slot `((setq ,slot (std-instance-slots ,argument))))
 412              (std-instance-wrapper ,argument))
 413             ((fsc-instance-p ,argument)
 414              ,@(when slot `((setq ,slot (fsc-instance-slots ,argument))))
 415              (fsc-instance-wrapper ,argument))
 416             (t
 417              (go ,miss-label))))
 418     (class
 419      (when slot (error "can't do a slot reg for this metatype"))
 420      `(wrapper-of-macro ,argument))
 421     ((built-in-instance structure-instance)
 422      (when slot (error "can't do a slot reg for this metatype"))
 423      `(built-in-or-structure-wrapper
 424        ,argument))))
 425