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-lambda 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-boundp-check (value-form miss-fn arglist)
 169   `(let ((value ,value-form))
 170      (if (eq value *slot-unbound*)
 171          (funcall ,miss-fn ,@arglist)
 172          value)))
 173
 174 (defun emit-slot-access (reader/writer class-slot-p slots index miss-fn arglist)
 175   (let ((read-form (emit-slot-read-form class-slot-p index slots)))
 176     (ecase reader/writer
 177       (:reader (emit-boundp-check read-form miss-fn arglist))
 178       (:writer `(setf ,read-form ,(car arglist))))))
 179
 180 (defmacro emit-reader/writer-macro (reader/writer 1-or-2-class class-slot-p)
 181   (let ((*emit-function-p* nil)
 182         (*precompiling-lap* t))
 183     (values
 184      (emit-reader/writer reader/writer 1-or-2-class class-slot-p))))
 185
 186 (defun emit-one-or-n-index-reader/writer (reader/writer cached-index-p class-slot-p)
 187   (when (and (null *precompiling-lap*) *emit-function-p*)
 188     (return-from emit-one-or-n-index-reader/writer
 189       (emit-one-or-n-index-reader/writer-function
 190        reader/writer cached-index-p class-slot-p)))
 191   (multiple-value-bind (arglist metatypes)
 192       (ecase reader/writer
 193         (:reader (values (list (dfun-arg-symbol 0))
 194                          '(standard-instance)))
 195         (:writer (values (list (dfun-arg-symbol 0) (dfun-arg-symbol 1))
 196                          '(t standard-instance))))
 197     (generating-lisp `(cache ,@(unless cached-index-p '(index)) miss-fn)
 198                      arglist
 199       `(let (,@(unless class-slot-p '(slots))
 200              ,@(when cached-index-p '(index)))
 201          ,(emit-dlap arglist metatypes
 202                      (emit-slot-access reader/writer class-slot-p
 203                                        'slots 'index 'miss-fn arglist)
 204                      `(funcall miss-fn ,@arglist)
 205                      (when cached-index-p 'index)
 206                      (unless class-slot-p '(slots)))))))
 207
 208 (defmacro emit-one-or-n-index-reader/writer-macro
 209     (reader/writer cached-index-p class-slot-p)
 210   (let ((*emit-function-p* nil)
 211         (*precompiling-lap* t))
 212     (values
 213      (emit-one-or-n-index-reader/writer reader/writer cached-index-p class-slot-p))))
 214
 215 (defun emit-miss (miss-fn args &optional applyp)
 216   (let ((restl (when applyp '(.lap-rest-arg.))))
 217     (if restl
 218         `(apply ,miss-fn ,@args ,@restl)
 219         `(funcall ,miss-fn ,@args ,@restl))))
 220
 221 (defun emit-checking-or-caching (cached-emf-p return-value-p metatypes applyp)
 222   (when (and (null *precompiling-lap*) *emit-function-p*)
 223     (return-from emit-checking-or-caching
 224       (emit-checking-or-caching-function
 225        cached-emf-p return-value-p metatypes applyp)))
 226   (let* ((dlap-lambda-list (make-dlap-lambda-list metatypes applyp))
 227          (args (remove '&rest dlap-lambda-list))
 228          (restl (when applyp '(.lap-rest-arg.))))
 229     (generating-lisp `(cache ,@(unless cached-emf-p '(emf)) miss-fn)
 230                      dlap-lambda-list
 231       `(let (,@(when cached-emf-p '(emf)))
 232          ,(emit-dlap args
 233                      metatypes
 234                      (if return-value-p
 235                          (if cached-emf-p 'emf t)
 236                          `(invoke-effective-method-function emf ,applyp
 237                            ,@args ,@restl))
 238                      (emit-miss 'miss-fn args applyp)
 239                      (when cached-emf-p 'emf))))))
 240
 241 (defmacro emit-checking-or-caching-macro (cached-emf-p return-value-p metatypes applyp)
 242   (let ((*emit-function-p* nil)
 243         (*precompiling-lap* t))
 244     (values
 245      (emit-checking-or-caching cached-emf-p return-value-p metatypes applyp))))
 246
 247 (defun emit-dlap (args metatypes hit miss value-reg &optional slot-regs)
 248   (let* ((index -1)
 249          (wrapper-bindings (mapcan #'(lambda (arg mt)
 250                                        (unless (eq mt 't)
 251                                          (incf index)
 252                                          `((,(intern (format nil
 253                                                              "WRAPPER-~D"
 254                                                              index)
 255                                                      *pcl-package*)
 256                                             ,(emit-fetch-wrapper mt arg 'miss
 257                                               (pop slot-regs))))))
 258                                    args metatypes))
 259          (wrappers (mapcar #'car wrapper-bindings)))
 260     (declare (fixnum index))
 261     (unless wrappers (error "Every metatype is T."))
 262     `(block dfun
 263        (tagbody
 264           (let ((field (cache-field cache))
 265                 (cache-vector (cache-vector cache))
 266                 (mask (cache-mask cache))
 267                 (size (cache-size cache))
 268                 (overflow (cache-overflow cache))
 269                 ,@wrapper-bindings)
 270             (declare (fixnum size field mask))
 271             ,(cond ((cdr wrappers)
 272                     (emit-greater-than-1-dlap wrappers 'miss value-reg))
 273                    (value-reg
 274                     (emit-1-t-dlap (car wrappers) 'miss value-reg))
 275                    (t
 276                     (emit-1-nil-dlap (car wrappers) 'miss)))
 277             (return-from dfun ,hit))
 278         miss
 279           (return-from dfun ,miss)))))
 280
 281 (defun emit-1-nil-dlap (wrapper miss-label)
 282   `(let* ((primary ,(emit-1-wrapper-compute-primary-cache-location wrapper miss-label))
 283           (location primary))
 284      (declare (fixnum primary location))
 285      (block search
 286        (loop (when (eq ,wrapper (cache-vector-ref cache-vector location))
 287                (return-from search nil))
 288              (setq location (the fixnum (+ location 1)))
 289              (when (= location size)
 290                (setq location 0))
 291              (when (= location primary)
 292                (dolist (entry overflow)
 293                  (when (eq (car entry) ,wrapper)
 294                    (return-from search nil)))
 295                (go ,miss-label))))))
 296
 297 (defmacro get-cache-vector-lock-count (cache-vector)
 298   `(let ((lock-count (cache-vector-lock-count ,cache-vector)))
 299      (unless (typep lock-count 'fixnum)
 300        (error "My cache got freed somehow."))
 301      (the fixnum lock-count)))
 302
 303 (defun emit-1-t-dlap (wrapper miss-label value)
 304   `(let ((primary ,(emit-1-wrapper-compute-primary-cache-location wrapper miss-label))
 305          (initial-lock-count (get-cache-vector-lock-count cache-vector)))
 306      (declare (fixnum primary initial-lock-count))
 307      (let ((location primary))
 308        (declare (fixnum location))
 309        (block search
 310          (loop (when (eq ,wrapper (cache-vector-ref cache-vector location))
 311                  (setq ,value (cache-vector-ref cache-vector (1+ location)))
 312                  (return-from search nil))
 313                (setq location (the fixnum (+ location 2)))
 314                (when (= location size)
 315                  (setq location 0))
 316                (when (= location primary)
 317                  (dolist (entry overflow)
 318                    (when (eq (car entry) ,wrapper)
 319                      (setq ,value (cdr entry))
 320                      (return-from search nil)))
 321                  (go ,miss-label))))
 322        (unless (= initial-lock-count
 323                   (get-cache-vector-lock-count cache-vector))
 324          (go ,miss-label)))))
 325
 326 (defun emit-greater-than-1-dlap (wrappers miss-label value)
 327   (declare (type list wrappers))
 328   (let ((cache-line-size (compute-line-size (+ (length wrappers) (if value 1 0)))))
 329     `(let ((primary 0) (size-1 (the fixnum (- size 1))))
 330        (declare (fixnum primary size-1))
 331        ,(emit-n-wrapper-compute-primary-cache-location wrappers miss-label)
 332        (let ((initial-lock-count (get-cache-vector-lock-count cache-vector)))
 333          (declare (fixnum initial-lock-count))
 334          (let ((location primary) (next-location 0))
 335            (declare (fixnum location next-location))
 336            (block search
 337              (loop (setq next-location (the fixnum (+ location ,cache-line-size)))
 338                    (when (and ,@(mapcar
 339                                  #'(lambda (wrapper)
 340                                      `(eq ,wrapper
 341                                        (cache-vector-ref cache-vector
 342                                         (setq location
 343                                          (the fixnum (+ location 1))))))
 344                                  wrappers))
 345                      ,@(when value
 346                          `((setq location (the fixnum (+ location 1)))
 347                            (setq ,value (cache-vector-ref cache-vector location))))
 348                      (return-from search nil))
 349                    (setq location next-location)
 350                    (when (= location size-1)
 351                      (setq location 0))
 352                    (when (= location primary)
 353                      (dolist (entry overflow)
 354                        (let ((entry-wrappers (car entry)))
 355                          (when (and ,@(mapcar #'(lambda (wrapper)
 356                                                   `(eq ,wrapper (pop entry-wrappers)))
 357                                               wrappers))
 358                            ,@(when value
 359                                `((setq ,value (cdr entry))))
 360                            (return-from search nil))))
 361                      (go ,miss-label))))
 362            (unless (= initial-lock-count
 363                       (get-cache-vector-lock-count cache-vector))
 364              (go ,miss-label)))))))
 365
 366 (defun emit-1-wrapper-compute-primary-cache-location (wrapper miss-label)
 367   `(let ((wrapper-cache-no (wrapper-cache-number-vector-ref ,wrapper field)))
 368      (declare (fixnum wrapper-cache-no))
 369      (when (zerop wrapper-cache-no) (go ,miss-label))
 370      ,(let ((form `(logand mask wrapper-cache-no)))
 371         `(the fixnum ,form))))
 372
 373 (defun emit-n-wrapper-compute-primary-cache-location (wrappers miss-label)
 374   (declare (type list wrappers))
 375   ;; This returns 1 less that the actual location.
 376   `(progn
 377      ,@(let ((adds 0) (len (length wrappers)))
 378          (declare (fixnum adds len))
 379          (mapcar #'(lambda (wrapper)
 380                      `(let ((wrapper-cache-no (wrapper-cache-number-vector-ref
 381                                                ,wrapper field)))
 382                         (declare (fixnum wrapper-cache-no))
 383                         (when (zerop wrapper-cache-no) (go ,miss-label))
 384                         (setq primary (the fixnum (+ primary wrapper-cache-no)))
 385                         ,@(progn
 386                             (incf adds)
 387                             (when (or (zerop (mod adds wrapper-cache-number-adds-ok))
 388                                       (eql adds len))
 389                               `((setq primary
 390                                       ,(let ((form `(logand primary mask)))
 391                                          `(the fixnum ,form))))))))
 392                  wrappers))))
 393
 394 ;;; CMU17 (and SBCL) note: Since STD-INSTANCE-P is weakened in the CMU/SBCL
 395 ;;; approach of using funcallable instances, that branch may run
 396 ;;; on non-pcl instances (structures). The result will be the
 397 ;;; non-wrapper layout for the structure, which will cause a miss. The "slots"
 398 ;;; will be whatever the first slot is, but will be ignored. Similarly,
 399 ;;; fsc-instance-p returns true on funcallable structures as well as PCL fins.
 400 (defun emit-fetch-wrapper (metatype argument miss-label &optional slot)
 401   (ecase metatype
 402     ((standard-instance)
 403      `(cond ((std-instance-p ,argument)
 404              ,@(when slot `((setq ,slot (std-instance-slots ,argument))))
 405              (std-instance-wrapper ,argument))
 406             ((fsc-instance-p ,argument)
 407              ,@(when slot `((setq ,slot (fsc-instance-slots ,argument))))
 408              (fsc-instance-wrapper ,argument))
 409             (t
 410              (go ,miss-label))))
 411     (class
 412      (when slot (error "can't do a slot reg for this metatype"))
 413      `(wrapper-of-macro ,argument))
 414     ((built-in-instance structure-instance)
 415      (when slot (error "can't do a slot reg for this metatype"))
 416      `(built-in-or-structure-wrapper
 417        ,argument))))
 418