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