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
  27 ;;;; some support stuff for getting a hold of symbols that we need when
  28 ;;;; building the discriminator codes. It's OK for these to be interned
  29 ;;;; symbols because we don't capture any user code in the scope in which
  30 ;;;; these symbols are bound.
  31
  32 (declaim (list *dfun-arg-symbols*))
  33 (defvar *dfun-arg-symbols* '(.ARG0. .ARG1. .ARG2. .ARG3.))
  34
  35 (defun dfun-arg-symbol (arg-number)
  36   (or (nth arg-number *dfun-arg-symbols*)
  37       (format-symbol *pcl-package* ".ARG~A." arg-number)))
  38
  39 (declaim (list *slot-vector-symbols*))
  40 (defvar *slot-vector-symbols* '(.SLOTS0. .SLOTS1. .SLOTS2. .SLOTS3.))
  41
  42 (defun slot-vector-symbol (arg-number)
  43   (or (nth arg-number *slot-vector-symbols*)
  44       (format-symbol *pcl-package* ".SLOTS~A." arg-number)))
  45
  46 (declaim (inline make-dfun-required-args))
  47 (defun make-dfun-required-args (count)
  48   (declare (type index count))
  49   (let (result)
  50     (dotimes (i count (nreverse result))
  51       (push (dfun-arg-symbol i) result))))
  52
  53 (defun make-dfun-lambda-list (nargs applyp)
  54   (let ((required (make-dfun-required-args nargs)))
  55     (if applyp
  56         (nconc required
  57                ;; Use &MORE arguments to avoid consing up an &REST list
  58                ;; that we might not need at all. See MAKE-EMF-CALL and
  59                ;; INVOKE-EFFECTIVE-METHOD-FUNCTION for the other
  60                ;; pieces.
  61                '(&more .dfun-more-context. .dfun-more-count.))
  62         required)))
  63
  64 (defun make-dlap-lambda-list (nargs applyp)
  65   (let* ((required (make-dfun-required-args nargs))
  66          (lambda-list (if applyp
  67                           (append required '(&more .more-context. .more-count.))
  68                           required)))
  69     ;; Return the full lambda list, the required arguments, a form
  70     ;; that will generate a rest-list, and a list of the &MORE
  71     ;; parameters used.
  72     (values lambda-list
  73             required
  74             (when applyp
  75               '((sb-c::%listify-rest-args
  76                  .more-context.
  77                  (the (and unsigned-byte fixnum)
  78                    .more-count.))))
  79             (when applyp
  80               '(.more-context. .more-count.)))))
  81
  82 (defun make-emf-call (nargs applyp fn-variable &optional emf-type)
  83   (let ((required (make-dfun-required-args nargs)))
  84     `(,(if (eq emf-type 'fast-method-call)
  85            'invoke-effective-method-function-fast
  86            'invoke-effective-method-function)
  87        ,fn-variable
  88        ,applyp
  89        :required-args ,required
  90        ;; INVOKE-EFFECTIVE-METHOD-FUNCTION will decide whether to use
  91        ;; the :REST-ARG version or the :MORE-ARG version depending on
  92        ;; the type of the EMF.
  93        :rest-arg ,(if applyp
  94                       ;; Creates a list from the &MORE arguments.
  95                       '((sb-c::%listify-rest-args
  96                          .dfun-more-context.
  97                          (the (and unsigned-byte fixnum)
  98                            .dfun-more-count.)))
  99                       nil)
 100        :more-arg ,(when applyp
 101                     '(.dfun-more-context. .dfun-more-count.)))))
 102
 103 (defun make-fast-method-call-lambda-list (nargs applyp)
 104   (list* '.pv-cell. '.next-method-call. (make-dfun-lambda-list nargs applyp)))
 105 \f
 106 ;;; Emitting various accessors.
 107
 108 (defun emit-one-class-reader (class-slot-p)
 109   (emit-reader/writer :reader 1 class-slot-p))
 110
 111 (defun emit-one-class-boundp (class-slot-p)
 112   (emit-reader/writer :boundp 1 class-slot-p))
 113
 114 (defun emit-one-class-writer (class-slot-p)
 115   (emit-reader/writer :writer 1 class-slot-p))
 116
 117 (defun emit-two-class-reader (class-slot-p)
 118   (emit-reader/writer :reader 2 class-slot-p))
 119
 120 (defun emit-two-class-boundp (class-slot-p)
 121   (emit-reader/writer :boundp 2 class-slot-p))
 122
 123 (defun emit-two-class-writer (class-slot-p)
 124   (emit-reader/writer :writer 2 class-slot-p))
 125
 126 ;;; --------------------------------
 127
 128 (defun emit-one-index-readers (class-slot-p)
 129   (emit-one-or-n-index-reader/writer :reader nil class-slot-p))
 130
 131 (defun emit-one-index-boundps (class-slot-p)
 132   (emit-one-or-n-index-reader/writer :boundp nil class-slot-p))
 133
 134 (defun emit-one-index-writers (class-slot-p)
 135   (emit-one-or-n-index-reader/writer :writer nil class-slot-p))
 136
 137 (defun emit-n-n-readers ()
 138   (emit-one-or-n-index-reader/writer :reader t nil))
 139
 140 (defun emit-n-n-boundps ()
 141   (emit-one-or-n-index-reader/writer :boundp t nil))
 142
 143 (defun emit-n-n-writers ()
 144   (emit-one-or-n-index-reader/writer :writer t nil))
 145
 146 ;;; --------------------------------
 147
 148 (defun emit-checking (metatypes applyp)
 149   (emit-checking-or-caching nil nil metatypes applyp))
 150
 151 (defun emit-caching (metatypes applyp)
 152   (emit-checking-or-caching t nil metatypes applyp))
 153
 154 (defun emit-in-checking-cache-p (metatypes)
 155   (emit-checking-or-caching nil t metatypes nil))
 156
 157 (defun emit-constant-value (metatypes)
 158   (emit-checking-or-caching t t metatypes nil))
 159
 160 ;;; --------------------------------
 161
 162 ;;; FIXME: What do these variables mean?
 163 (defvar *precompiling-lap* nil)
 164 (defvar *emit-function-p* t)
 165
 166 ;;; FIXME: This variable is motivated by Gerd Moellman's observation,
 167 ;;; in <867kga1wra.fsf@gerd.free-bsd.org> on cmucl-imp 2002-10-22,
 168 ;;; that the functions returned from EMIT-xxx-FUNCTION can cause an
 169 ;;; order-of-magnitude slowdown.  We include this variable for now,
 170 ;;; but maybe its effect should rather be controlled by compilation
 171 ;;; policy if there is a noticeable space difference between the
 172 ;;; branches, or else maybe the EMIT-xxx-FUNCTION branches should be
 173 ;;; deleted.  It's not clear to me how all of this works, though, so
 174 ;;; until proper benchmarks are done it's probably safest simply to
 175 ;;; have this pseudo-constant to hide code.  -- CSR, 2003-02-14
 176 (defvar *optimize-cache-functions-p* t)
 177
 178 (defun emit-default-only (metatypes applyp)
 179   (unless *optimize-cache-functions-p*
 180     (when (and (null *precompiling-lap*) *emit-function-p*)
 181       (return-from emit-default-only
 182         (emit-default-only-function metatypes applyp))))
 183   (multiple-value-bind (lambda-list args rest-arg more-arg)
 184       (make-dlap-lambda-list (length metatypes) applyp)
 185     (generating-lisp '(emf)
 186                      lambda-list
 187                      `(invoke-effective-method-function emf
 188                                                         ,applyp
 189                                                         :required-args ,args
 190                                                         :more-arg ,more-arg
 191                                                         :rest-arg ,rest-arg))))
 192
 193 ;;; --------------------------------
 194
 195 (defun generating-lisp (closure-variables args form)
 196   (let ((lambda `(lambda ,closure-variables
 197                    ,@(when (member 'miss-fn closure-variables)
 198                            `((declare (type function miss-fn))))
 199                    #'(lambda ,args
 200                        (let ()
 201                          (declare #.*optimize-speed*)
 202                          ,form)))))
 203     (values (if *precompiling-lap*
 204                 `#',lambda
 205                 (compile nil lambda))
 206             nil)))
 207
 208 ;;; note on implementation for CMU 17 and later (including SBCL):
 209 ;;; Since STD-INSTANCE-P is weakened, that branch may run on non-PCL
 210 ;;; instances (structures). The result will be the non-wrapper layout
 211 ;;; for the structure, which will cause a miss. The "slots" will be
 212 ;;; whatever the first slot is, but will be ignored. Similarly,
 213 ;;; FSC-INSTANCE-P returns true on funcallable structures as well as
 214 ;;; PCL fins.
 215 (defun emit-reader/writer (reader/writer 1-or-2-class class-slot-p)
 216   (unless *optimize-cache-functions-p*
 217     (when (and (null *precompiling-lap*) *emit-function-p*)
 218       (return-from emit-reader/writer
 219         (emit-reader/writer-function
 220          reader/writer 1-or-2-class class-slot-p))))
 221   (let ((instance nil)
 222         (arglist  ())
 223         (closure-variables ())
 224         (read-form (emit-slot-read-form class-slot-p 'index 'slots)))
 225     (ecase reader/writer
 226       ((:reader :boundp)
 227        (setq instance (dfun-arg-symbol 0)
 228              arglist  (list instance)))
 229       (:writer (setq instance (dfun-arg-symbol 1)
 230                      arglist  (list (dfun-arg-symbol 0) instance))))
 231     (ecase 1-or-2-class
 232       (1 (setq closure-variables '(wrapper-0 index miss-fn)))
 233       (2 (setq closure-variables '(wrapper-0 wrapper-1 index miss-fn))))
 234     (generating-lisp
 235      closure-variables
 236      arglist
 237      `(let* (,@(unless class-slot-p `((slots nil)))
 238                (wrapper (cond ((std-instance-p ,instance)
 239                                ,@(unless class-slot-p
 240                                    `((setq slots
 241                                            (std-instance-slots ,instance))))
 242                                (std-instance-wrapper ,instance))
 243                               ((fsc-instance-p ,instance)
 244                                ,@(unless class-slot-p
 245                                    `((setq slots
 246                                            (fsc-instance-slots ,instance))))
 247                                (fsc-instance-wrapper ,instance)))))
 248         (block access
 249           (when (and wrapper
 250                      (not (zerop (layout-clos-hash wrapper)))
 251                      ,@(if (eql 1 1-or-2-class)
 252                            `((eq wrapper wrapper-0))
 253                            `((or (eq wrapper wrapper-0)
 254                                  (eq wrapper wrapper-1)))))
 255             ,@(ecase reader/writer
 256                 (:reader
 257                  `((let ((value ,read-form))
 258                      (unless (eq value +slot-unbound+)
 259                        (return-from access value)))))
 260                 (:boundp
 261                  `((let ((value ,read-form))
 262                      (return-from access (not (eq value +slot-unbound+))))))
 263                 (:writer
 264                  `((return-from access (setf ,read-form ,(car arglist)))))))
 265           (funcall miss-fn ,@arglist))))))
 266
 267 (defun emit-slot-read-form (class-slot-p index slots)
 268   (if class-slot-p
 269       `(cdr ,index)
 270       `(clos-slots-ref ,slots ,index)))
 271
 272 (defun emit-boundp-check (value-form miss-fn arglist)
 273   `(let ((value ,value-form))
 274      (if (eq value +slot-unbound+)
 275          (funcall ,miss-fn ,@arglist)
 276          value)))
 277
 278 (defun emit-slot-access (reader/writer class-slot-p slots
 279                          index miss-fn arglist)
 280   (let ((read-form (emit-slot-read-form class-slot-p index slots)))
 281     (ecase reader/writer
 282       (:reader (emit-boundp-check read-form miss-fn arglist))
 283       (:boundp `(not (eq ,read-form +slot-unbound+)))
 284       (:writer `(setf ,read-form ,(car arglist))))))
 285
 286 (defmacro emit-reader/writer-macro (reader/writer 1-or-2-class class-slot-p)
 287   (let ((*emit-function-p* nil)
 288         (*precompiling-lap* t))
 289     (values
 290      (emit-reader/writer reader/writer 1-or-2-class class-slot-p))))
 291
 292 (defun emit-one-or-n-index-reader/writer (reader/writer
 293                                           cached-index-p
 294                                           class-slot-p)
 295   (unless *optimize-cache-functions-p*
 296     (when (and (null *precompiling-lap*) *emit-function-p*)
 297       (return-from emit-one-or-n-index-reader/writer
 298         (emit-one-or-n-index-reader/writer-function
 299          reader/writer cached-index-p class-slot-p))))
 300   (multiple-value-bind (arglist metatypes)
 301       (ecase reader/writer
 302         ((:reader :boundp)
 303          (values (list (dfun-arg-symbol 0))
 304                  '(standard-instance)))
 305         (:writer (values (list (dfun-arg-symbol 0) (dfun-arg-symbol 1))
 306                          '(t standard-instance))))
 307     (generating-lisp
 308      `(cache ,@(unless cached-index-p '(index)) miss-fn)
 309      arglist
 310      `(let (,@(unless class-slot-p '(slots))
 311             ,@(when cached-index-p '(index)))
 312         ,(emit-dlap 'cache arglist metatypes
 313                     (emit-slot-access reader/writer class-slot-p
 314                                       'slots 'index 'miss-fn arglist)
 315                     `(funcall miss-fn ,@arglist)
 316                     (when cached-index-p 'index)
 317                     (unless class-slot-p '(slots)))))))
 318
 319 (defmacro emit-one-or-n-index-reader/writer-macro
 320     (reader/writer cached-index-p class-slot-p)
 321   (let ((*emit-function-p* nil)
 322         (*precompiling-lap* t))
 323     (values
 324      (emit-one-or-n-index-reader/writer reader/writer
 325                                         cached-index-p
 326                                         class-slot-p))))
 327
 328 (defun emit-miss (miss-fn args applyp)
 329   (if applyp
 330       `(multiple-value-call ,miss-fn ,@args
 331                             (sb-c::%more-arg-values .more-context.
 332                                                     0
 333                                                     .more-count.))
 334       `(funcall ,miss-fn ,@args)))
 335
 336 (defun emit-checking-or-caching (cached-emf-p return-value-p metatypes applyp)
 337   (unless *optimize-cache-functions-p*
 338     (when (and (null *precompiling-lap*) *emit-function-p*)
 339       (return-from emit-checking-or-caching
 340         (emit-checking-or-caching-function
 341          cached-emf-p return-value-p metatypes applyp))))
 342   (multiple-value-bind (lambda-list args rest-arg more-arg)
 343       (make-dlap-lambda-list (length metatypes) applyp)
 344     (generating-lisp
 345      `(cache ,@(unless cached-emf-p '(emf)) miss-fn)
 346      lambda-list
 347      `(let (,@(when cached-emf-p '(emf)))
 348         ,(emit-dlap 'cache args metatypes
 349                     (if return-value-p
 350                         (if cached-emf-p 'emf t)
 351                         `(invoke-effective-method-function
 352                           emf ,applyp
 353                           :required-args ,args
 354                           :more-arg ,more-arg
 355                           :rest-arg ,rest-arg))
 356                     (emit-miss 'miss-fn args applyp)
 357                     (when cached-emf-p 'emf))))))
 358
 359 (defmacro emit-checking-or-caching-macro (cached-emf-p
 360                                           return-value-p
 361                                           metatypes
 362                                           applyp)
 363   (let ((*emit-function-p* nil)
 364         (*precompiling-lap* t))
 365     (values
 366      (emit-checking-or-caching cached-emf-p return-value-p metatypes applyp))))
 367
 368 (defun emit-dlap (cache-var args metatypes hit-form miss-form value-var
 369                   &optional slot-vars)
 370   (let* ((index -1)
 371          (miss-tag (gensym "MISSED"))
 372          (wrapper-bindings (mapcan (lambda (arg mt)
 373                                      (unless (eq mt t)
 374                                        (incf index)
 375                                        `((,(format-symbol *pcl-package*
 376                                                           "WRAPPER-~D"
 377                                                           index)
 378                                           ,(emit-fetch-wrapper
 379                                             mt arg miss-tag (pop slot-vars))))))
 380                                    args metatypes))
 381          (wrapper-vars (mapcar #'car wrapper-bindings)))
 382     (declare (fixnum index))
 383     (unless wrapper-vars
 384       (error "Every metatype is T."))
 385     `(prog ()
 386         (return
 387           (let ,wrapper-bindings
 388             ,(emit-cache-lookup cache-var wrapper-vars miss-tag value-var)
 389             ,hit-form))
 390       ,miss-tag
 391         (return ,miss-form))))
 392
 393 ;;; CMU17 (and SBCL) note: Since STD-INSTANCE-P is weakened in the
 394 ;;; CMU/SBCL approach of using funcallable instances, that branch may
 395 ;;; run on non-pcl instances (structures). The result will be the
 396 ;;; non-wrapper layout for the structure, which will cause a miss. The
 397 ;;; "slots" will be whatever the first slot is, but will be ignored.
 398 ;;; Similarly, FSC-INSTANCE-P returns true on funcallable structures
 399 ;;; as well as PCL fins.
 400 (defun emit-fetch-wrapper (metatype argument miss-tag &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-tag))))
 411     ;; Sep92 PCL used to distinguish between some of these cases (and
 412     ;; spuriously exclude others).  Since in SBCL
 413     ;; WRAPPER-OF/LAYOUT-OF/BUILT-IN-OR-STRUCTURE-WRAPPER are all
 414     ;; equivalent and inlined to each other, we can collapse some
 415     ;; spurious differences.
 416     ((class built-in-instance structure-instance condition-instance)
 417      (when slot (error "can't do a slot reg for this metatype"))
 418      `(wrapper-of ,argument))
 419     ;; a metatype of NIL should never be seen here, as NIL is only in
 420     ;; the metatypes before a generic function is fully initialized.
 421     ;; T should never be seen because we never need to get a wrapper
 422     ;; to do dispatch if all methods have T as the respective
 423     ;; specializer.
 424     ((t nil)
 425      (bug "~@<metatype ~S seen in ~S.~@:>" metatype 'emit-fetch-wrapper))))