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