1;;;; permutation vectors 2 3;;;; This software is part of the SBCL system. See the README file for 4;;;; more information. 5 6;;;; This software is derived from software originally released by Xerox 7;;;; Corporation. Copyright and release statements follow. Later modifications 8;;;; to the software are in the public domain and are provided with 9;;;; absolutely no warranty. See the COPYING and CREDITS files for more 10;;;; information. 11 12;;;; copyright information from original PCL sources: 13;;;; 14;;;; Copyright (c) 1985, 1986, 1987, 1988, 1989, 1990 Xerox Corporation. 15;;;; All rights reserved. 16;;;; 17;;;; Use and copying of this software and preparation of derivative works based 18;;;; upon this software are permitted. Any distribution of this software or 19;;;; derivative works must comply with all applicable United States export 20;;;; control laws. 21;;;; 22;;;; This software is made available AS IS, and Xerox Corporation makes no 23;;;; warranty about the software, its performance or its conformity to any 24;;;; specification. 25 26(in-package "SB-PCL") 27 28;;;; Up to 1.0.9.24 SBCL used to have a sketched out implementation 29;;;; for optimizing GF calls inside method bodies using a PV approach, 30;;;; inherited from the original PCL. This was never completed, and 31;;;; was removed at that point to make the code easier to understand 32;;;; -- but: 33;;;; 34;;;; FIXME: It would be possible to optimize GF calls inside method 35;;;; bodies using permutation vectors: if all the arguments to the 36;;;; GF are specializers parameters, we can assign a permutation index 37;;;; to each such (GF . ARGS) tuple inside a method body, and use this 38;;;; to cache effective method functions. 39 40(declaim (inline make-pv-table)) 41(defstruct (pv-table (:predicate pv-tablep) 42 (:copier nil)) 43 (cache nil :type (or cache null)) 44 (pv-size 0 :type fixnum) 45 (slot-name-lists nil :type list)) 46 47(defun make-pv-table-type-declaration (var) 48 `(type pv-table ,var)) 49 50;;; Used for interning parts of SLOT-NAME-LISTS, as part of 51;;; PV-TABLE interning -- just to save space. 52(defvar *slot-name-lists* (make-hash-table :test 'equal)) 53 54;;; Used for interning PV-TABLES, keyed by the SLOT-NAME-LISTS 55;;; used. 56(defvar *pv-tables* (make-hash-table :test 'equal)) 57 58;;; ...and one lock to rule them. Lock because for certain (rare) 59;;; cases this lock might be grabbed in the course of method dispatch 60;;; -- and mostly this is already under the *world-lock* 61(defvar *pv-lock* 62 (sb-thread:make-mutex :name "pv table index lock")) 63 64(defun intern-pv-table (&key slot-name-lists) 65 (flet ((intern-slot-names (slot-names) 66 (or (gethash slot-names *slot-name-lists*) 67 (setf (gethash slot-names *slot-name-lists*) slot-names))) 68 (%intern-pv-table (snl) 69 (or (gethash snl *pv-tables*) 70 (setf (gethash snl *pv-tables*) 71 (make-pv-table :slot-name-lists snl 72 :pv-size (* 2 (reduce #'+ snl :key #'length))))))) 73 (sb-thread:with-mutex (*pv-lock*) 74 (%intern-pv-table (mapcar #'intern-slot-names slot-name-lists))))) 75 76(defun use-standard-slot-access-p (class slot-name type) 77 (or (not (eq **boot-state** 'complete)) 78 (and (standard-class-p class) 79 (let ((slotd (find-slot-definition class slot-name))) 80 (and slotd 81 (slot-accessor-std-p slotd type)))))) 82 83(defun slot-missing-info (class slot-name) 84 (make-slot-info 85 :reader (lambda (object) 86 (values (slot-missing class object slot-name 'slot-value))) 87 :boundp (lambda (object) 88 (and (slot-missing class object slot-name 'slot-boundp) t)) 89 :writer (lambda (new-value object) 90 (slot-missing class object slot-name 'setf new-value) 91 new-value))) 92 93(defun compute-pv (slot-name-lists wrappers) 94 (let ((wrappers (ensure-list wrappers))) 95 (collect ((pv)) 96 (dolist (slot-names slot-name-lists) 97 (when slot-names 98 (let* ((wrapper (pop wrappers)) 99 (std-p (layout-for-std-class-p wrapper)) 100 (class (wrapper-class* wrapper))) 101 (dolist (slot-name slot-names) 102 (destructuring-bind (location . info) 103 (or (find-slot-cell wrapper slot-name) 104 (cons nil (slot-missing-info class slot-name))) 105 (unless info 106 (bug "No SLOT-INFO for ~S in ~S" slot-name class)) 107 (pv (when (and std-p (use-standard-slot-access-p class slot-name 'all)) 108 location)) 109 (pv info)))))) 110 (coerce (pv) 'vector)))) 111 112(defun pv-table-lookup (pv-table pv-wrappers) 113 (let* ((slot-name-lists (pv-table-slot-name-lists pv-table)) 114 (cache (or (pv-table-cache pv-table) 115 (setf (pv-table-cache pv-table) 116 (make-cache :key-count (- (length slot-name-lists) 117 (count nil slot-name-lists)) 118 :value t 119 :size 2))))) 120 (multiple-value-bind (hitp value) (probe-cache cache pv-wrappers) 121 (if hitp 122 value 123 (let* ((pv (compute-pv slot-name-lists pv-wrappers)) 124 (new-cache (fill-cache cache pv-wrappers pv))) 125 ;; This is safe: if another thread races us here the loser just 126 ;; misses the next time as well. 127 (unless (eq new-cache cache) 128 (setf (pv-table-cache pv-table) new-cache)) 129 pv))))) 130 131(defun make-pv-type-declaration (var) 132 `(type simple-vector ,var)) 133 134;;; Sometimes we want to finalize if we can, but it's OK if 135;;; we can't. 136(defun try-finalize-inheritance (class) 137 (unless (typep class 'forward-referenced-class) 138 (when (every (lambda (super) 139 (or (eq super class) 140 (class-finalized-p super) 141 (try-finalize-inheritance super))) 142 (class-direct-superclasses class)) 143 (finalize-inheritance class) 144 t))) 145 146(declaim (ftype (sfunction (class) class) ensure-class-finalized) 147 (maybe-inline ensure-class-finalized)) 148(defun ensure-class-finalized (class) 149 (unless (class-finalized-p class) 150 (finalize-inheritance class)) 151 class) 152 153(defun can-optimize-access (form required-parameters env) 154 (destructuring-bind (op var-form slot-name-form &optional new-value) form 155 (let ((type (ecase op 156 (slot-value 'reader) 157 (set-slot-value 'writer) 158 (slot-boundp 'boundp))) 159 (var (extract-the var-form)) 160 (slot-name (constant-form-value slot-name-form env))) 161 (when (and (symbolp var) (not (var-special-p var env))) 162 (let* ((rebound? (caddr (var-declaration '%variable-rebinding var env))) 163 (parameter-or-nil (car (memq (or rebound? var) 164 required-parameters)))) 165 (when parameter-or-nil 166 (let* ((class-name (caddr (var-declaration '%class 167 parameter-or-nil 168 env))) 169 (class (find-class class-name nil))) 170 (cond ((not (eq **boot-state** 'complete)) 171 (setq class nil)) 172 ((and class (not (class-finalized-p class))) 173 ;; The class itself is never forward-referenced 174 ;; here, but its superclasses may be. 175 (unless (try-finalize-inheritance class) 176 (when (boundp 'sb-c:*lexenv*) 177 (sb-c:compiler-notify 178 "~@<Cannot optimize slot access, inheritance of ~S is not ~ 179 yet finalizable due to forward-referenced superclasses:~ 180 ~% ~S~:@>" 181 class form)) 182 (setf class nil)))) 183 (when (and class-name (not (eq class-name t))) 184 (when (not (and class 185 (memq *the-class-structure-object* 186 (class-precedence-list class)))) 187 (aver type) 188 (values (cons parameter-or-nil (or class class-name)) 189 slot-name 190 new-value)))))))))) 191 192;;; Check whether the binding of the named variable is modified in the 193;;; method body. 194(defun parameter-modified-p (parameter-name env) 195 (let ((modified-variables (%macroexpand '%parameter-binding-modified env))) 196 (memq parameter-name modified-variables))) 197 198(defun optimize-slot-value (form slots required-parameters env) 199 (multiple-value-bind (sparameter slot-name) 200 (can-optimize-access form required-parameters env) 201 (if sparameter 202 (let ((optimized-form 203 (optimize-instance-access slots :read sparameter 204 slot-name nil))) 205 ;; We don't return the optimized form directly, since there's 206 ;; still a chance that we'll find out later on that the 207 ;; optimization should not have been done, for example due to 208 ;; the walker encountering a SETQ on SPARAMETER later on in 209 ;; the body [ see for example clos.impure.lisp test with :name 210 ;; ((:setq :method-parameter) slot-value)) ]. Instead we defer 211 ;; the decision until the compiler macroexpands 212 ;; OPTIMIZED-SLOT-VALUE. 213 ;; 214 ;; Note that we must still call OPTIMIZE-INSTANCE-ACCESS at 215 ;; this point (instead of when expanding 216 ;; OPTIMIZED-SLOT-VALUE), since it mutates the structure of 217 ;; SLOTS. If that mutation isn't done during the walking, 218 ;; MAKE-METHOD-LAMBDA-INTERNAL won't wrap a correct PV-BINDING 219 ;; form around the body, and compilation will fail. -- JES, 220 ;; 2006-09-18 221 `(optimized-slot-value ,form ,(car sparameter) ,optimized-form)) 222 `(accessor-slot-value ,@(cdr form))))) 223 224(defmacro optimized-slot-value (form parameter-name optimized-form 225 &environment env) 226 ;; Either use OPTIMIZED-FORM or fall back to the safe 227 ;; ACCESSOR-SLOT-VALUE. 228 (if (parameter-modified-p parameter-name env) 229 `(accessor-slot-value ,@(cdr form)) 230 optimized-form)) 231 232(defun optimize-set-slot-value (form slots required-parameters env) 233 (multiple-value-bind (sparameter slot-name new-value) 234 (can-optimize-access form required-parameters env) 235 (if sparameter 236 (let ((optimized-form 237 (optimize-instance-access slots :write sparameter 238 slot-name new-value (safe-code-p env)))) 239 ;; See OPTIMIZE-SLOT-VALUE 240 `(optimized-set-slot-value ,form ,(car sparameter) ,optimized-form)) 241 `(accessor-set-slot-value ,@(cdr form))))) 242 243(defmacro optimized-set-slot-value (form parameter-name optimized-form 244 &environment env) 245 (cond ((parameter-modified-p parameter-name env) 246 ;; ACCESSOR-SET-SLOT-VALUE doesn't do type-checking, 247 ;; so we need to use SAFE-SET-SLOT-VALUE. 248 (if (safe-code-p env) 249 `(safe-set-slot-value ,@(cdr form))) 250 `(accessor-set-slot-value ,@(cdr form))) 251 (t 252 optimized-form))) 253 254(defun optimize-slot-boundp (form slots required-parameters env) 255 (multiple-value-bind (sparameter slot-name) 256 (can-optimize-access form required-parameters env) 257 (if sparameter 258 (let ((optimized-form 259 (optimize-instance-access slots :boundp sparameter 260 slot-name nil))) 261 ;; See OPTIMIZE-SLOT-VALUE 262 `(optimized-slot-boundp ,form ,(car sparameter) ,optimized-form)) 263 `(accessor-slot-boundp ,@(cdr form))))) 264 265(defmacro optimized-slot-boundp (form parameter-name optimized-form 266 &environment env) 267 (if (parameter-modified-p parameter-name env) 268 `(accessor-slot-boundp ,@(cdr form)) 269 optimized-form)) 270 271;;; The SLOTS argument is an alist, the CAR of each entry is the name 272;;; of a required parameter to the function. The alist is in order, so 273;;; the position of an entry in the alist corresponds to the 274;;; argument's position in the lambda list. 275(defun optimize-instance-access (slots read/write sparameter slot-name 276 new-value &optional safep) 277 (let ((class (if (consp sparameter) (cdr sparameter) *the-class-t*)) 278 (parameter (if (consp sparameter) (car sparameter) sparameter))) 279 (if (and (eq **boot-state** 'complete) 280 (classp class) 281 (memq *the-class-structure-object* (class-precedence-list class))) 282 (let ((slotd (find-slot-definition class slot-name))) 283 (ecase read/write 284 (:read 285 `(,(slot-definition-defstruct-accessor-symbol slotd) ,parameter)) 286 (:write 287 `(setf (,(slot-definition-defstruct-accessor-symbol slotd) 288 ,parameter) 289 ,new-value)) 290 (:boundp 291 t))) 292 (let* ((parameter-entry (assq parameter slots)) 293 (slot-entry (assq slot-name (cdr parameter-entry))) 294 (position (posq parameter-entry slots)) 295 (pv-offset-form (list 'pv-offset ''.PV-OFFSET.))) 296 (unless parameter-entry 297 (bug "slot optimization bewilderment: O-I-A")) 298 (unless slot-entry 299 (setq slot-entry (list slot-name)) 300 (push slot-entry (cdr parameter-entry))) 301 (push pv-offset-form (cdr slot-entry)) 302 (ecase read/write 303 (:read 304 `(instance-read ,pv-offset-form ,parameter ,position 305 ',slot-name ',class)) 306 (:write 307 `(let ((.new-value. ,new-value)) 308 (instance-write ,pv-offset-form ,parameter ,position 309 ',slot-name ',class .new-value. ,safep))) 310 (:boundp 311 `(instance-boundp ,pv-offset-form ,parameter ,position 312 ',slot-name ',class))))))) 313 314(define-walker-template pv-offset) ; These forms get munged by mutate slots. 315(defmacro pv-offset (arg) arg) 316(define-walker-template instance-accessor-parameter) 317(defmacro instance-accessor-parameter (x) x) 318 319;;; It is safe for these two functions to be wrong. They just try to 320;;; guess what the most likely case will be. 321(defun generate-fast-class-slot-access-p (class-form slot-name-form) 322 (let ((class (and (constantp class-form) (constant-form-value class-form))) 323 (slot-name (and (constantp slot-name-form) 324 (constant-form-value slot-name-form)))) 325 (and (eq **boot-state** 'complete) 326 (standard-class-p class) 327 (not (eq class *the-class-t*)) ; shouldn't happen, though. 328 (let ((slotd (find-slot-definition class slot-name))) 329 (and slotd (eq :class (slot-definition-allocation slotd))))))) 330 331(defun constant-value-or-nil (form) 332 (and (constantp form) (constant-form-value form))) 333 334(defun slot-access-strategy (class slot-name type &optional conservative) 335 ;; CONSERVATIVE means we should assume custom access pattern even if 336 ;; there are no custom accessors defined if the metaclass is non-standard. 337 ;; 338 ;; This is needed because DEFCLASS generates accessor methods before possible 339 ;; SLOT-VALUE-USING-CLASS methods are defined, which causes them to take 340 ;; the slow path unless we make the conservative assumption here. 341 (if (eq **boot-state** 'complete) 342 (let (slotd) 343 (cond ((or 344 ;; Conditions, structures, and classes for which FIND-CLASS 345 ;; doesn't return them yet. 346 ;; FIXME: surely we can get faster accesses for structures? 347 (not (standard-class-p class)) 348 ;; Should not happen... (FIXME: assert instead?) 349 (eq class *the-class-t*) 350 (not (class-finalized-p class)) 351 ;; Strangeness... 352 (not (setf slotd (find-slot-definition class slot-name)))) 353 :accessor) 354 ((and (slot-accessor-std-p slotd type) 355 (or (not conservative) (eq *the-class-standard-class* (class-of class)))) 356 ;; The best case. 357 :standard) 358 (t 359 :custom))) 360 :standard)) 361 362;;;; SLOT-VALUE 363 364(defmacro instance-read (pv-offset parameter position slot-name class) 365 (ecase (slot-access-strategy (constant-value-or-nil class) 366 (constant-value-or-nil slot-name) 367 'reader) 368 (:standard 369 `(instance-read-standard 370 .pv. ,(slot-vector-symbol position) 371 ,pv-offset (accessor-slot-value ,parameter ,slot-name) 372 ,(if (generate-fast-class-slot-access-p class slot-name) 373 :class :instance))) 374 (:custom 375 `(instance-read-custom .pv. ,pv-offset ,parameter)) 376 (:accessor 377 `(accessor-slot-value ,parameter ,slot-name)))) 378 379(defmacro instance-read-standard (pv slots pv-offset default &optional kind) 380 (unless (member kind '(nil :instance :class)) 381 (error "illegal kind argument to ~S: ~S" 'instance-read-standard kind)) 382 (let* ((index (gensym)) 383 (value index)) 384 `(locally (declare #.*optimize-speed*) 385 (let ((,index (svref ,pv ,pv-offset)) 386 (,slots (truly-the simple-vector ,slots))) 387 (setq ,value (typecase ,index 388 ;; FIXME: the line marked by KLUDGE below (and 389 ;; the analogous spot in 390 ;; INSTANCE-WRITE-STANDARD) is there purely to 391 ;; suppress a type mismatch warning that 392 ;; propagates through to user code. 393 ;; Presumably SLOTS at this point can never 394 ;; actually be NIL, but the compiler seems to 395 ;; think it could, so we put this here to shut 396 ;; it up. (see also mail Rudi Schlatte 397 ;; sbcl-devel 2003-09-21) -- CSR, 2003-11-30 398 ,@(when (or (null kind) (eq kind :instance)) 399 `((fixnum 400 (clos-slots-ref ,slots ,index)))) 401 ,@(when (or (null kind) (eq kind :class)) 402 `((cons (cdr ,index)))) 403 (t 404 +slot-unbound+))) 405 (if (eq ,value +slot-unbound+) 406 ,default 407 ,value))))) 408 409(defmacro instance-read-custom (pv pv-offset parameter) 410 `(locally (declare #.*optimize-speed*) 411 (funcall (slot-info-reader (svref ,pv (1+ ,pv-offset))) ,parameter))) 412 413;;;; (SETF SLOT-VALUE) 414 415(defmacro instance-write (pv-offset parameter position slot-name class new-value 416 &optional check-type-p) 417 (ecase (slot-access-strategy (constant-value-or-nil class) 418 (constant-value-or-nil slot-name) 419 'writer) 420 (:standard 421 `(instance-write-standard 422 .pv. ,(slot-vector-symbol position) 423 ,pv-offset ,new-value 424 ;; KLUDGE: .GOOD-NEW-VALUE. is type-checked by the time this form 425 ;; is executed (if it is executed). 426 (accessor-set-slot-value ,parameter ,slot-name .good-new-value.) 427 ,(if (generate-fast-class-slot-access-p class slot-name) 428 :class :instance) 429 ,check-type-p)) 430 (:custom 431 `(instance-write-custom .pv. ,pv-offset ,parameter ,new-value)) 432 (:accessor 433 (if check-type-p 434 ;; FIXME: We don't want this here. If it's _possible_ the fast path 435 ;; is applicable, we want to use it as well. 436 `(safe-set-slot-value ,parameter ,slot-name ,new-value) 437 `(accessor-set-slot-value ,parameter ,slot-name ,new-value))))) 438 439(defmacro instance-write-standard (pv slots pv-offset new-value default 440 &optional kind safep) 441 (unless (member kind '(nil :instance :class)) 442 (error "illegal kind argument to ~S: ~S" 'instance-write-standard kind)) 443 (let* ((index (gensym)) 444 (new-value-form 445 (if safep 446 `(let ((.typecheckfun. (slot-info-typecheck (svref ,pv (1+ ,pv-offset))))) 447 (declare (type (or function null) .typecheckfun.)) 448 (if .typecheckfun. 449 (funcall .typecheckfun. ,new-value) 450 ,new-value)) 451 new-value))) 452 `(locally (declare #.*optimize-speed*) 453 (let ((.good-new-value. ,new-value-form) 454 (,index (svref ,pv ,pv-offset))) 455 (typecase ,index 456 ,@(when (or (null kind) (eq kind :instance)) 457 `((fixnum (and ,slots 458 (setf (clos-slots-ref ,slots ,index) 459 .good-new-value.))))) 460 ,@(when (or (null kind) (eq kind :class)) 461 `((cons (setf (cdr ,index) .good-new-value.)))) 462 (t ,default)))))) 463 464(defmacro instance-write-custom (pv pv-offset parameter new-value) 465 `(locally (declare #.*optimize-speed*) 466 (funcall (slot-info-writer (svref ,pv (1+ ,pv-offset))) ,new-value ,parameter))) 467 468;;;; SLOT-BOUNDP 469 470(defmacro instance-boundp (pv-offset parameter position slot-name class) 471 (ecase (slot-access-strategy (constant-value-or-nil class) 472 (constant-value-or-nil slot-name) 473 'boundp) 474 (:standard 475 `(instance-boundp-standard 476 .pv. ,(slot-vector-symbol position) 477 ,pv-offset (accessor-slot-boundp ,parameter ,slot-name) 478 ,(if (generate-fast-class-slot-access-p class slot-name) 479 :class :instance))) 480 (:custom 481 `(instance-boundp-custom .pv. ,pv-offset ,parameter)) 482 (:accessor 483 `(accessor-slot-boundp ,parameter ,slot-name)))) 484 485(defmacro instance-boundp-standard (pv slots pv-offset default 486 &optional kind) 487 (unless (member kind '(nil :instance :class)) 488 (error "illegal kind argument to ~S: ~S" 'instance-boundp-standard kind)) 489 (let* ((index (gensym))) 490 `(locally (declare #.*optimize-speed*) 491 (let ((,index (svref ,pv ,pv-offset))) 492 (typecase ,index 493 ,@(when (or (null kind) (eq kind :instance)) 494 `((fixnum (not (and ,slots 495 (eq (clos-slots-ref ,slots ,index) 496 +slot-unbound+)))))) 497 ,@(when (or (null kind) (eq kind :class)) 498 `((cons (not (eq (cdr ,index) +slot-unbound+))))) 499 (t ,default)))))) 500 501(defmacro instance-boundp-custom (pv pv-offset parameter) 502 `(locally (declare #.*optimize-speed*) 503 (funcall (slot-info-boundp (svref ,pv (1+ ,pv-offset))) ,parameter))) 504 505;;; This magic function has quite a job to do indeed. 506;;; 507;;; The careful reader will recall that <slots> contains all of the 508;;; optimized slot access forms produced by OPTIMIZE-INSTANCE-ACCESS. 509;;; Each of these is a call to either INSTANCE-READ or INSTANCE-WRITE. 510;;; 511;;; At the time these calls were produced, the first argument was 512;;; specified as the symbol .PV-OFFSET.; what we have to do now is 513;;; convert those pv-offset arguments into the actual number that is 514;;; the correct offset into the pv. 515;;; 516;;; But first, oh but first, we sort <slots> a bit so that for each 517;;; argument we have the slots in an order defined by 518;;; SYMBOL-OR-CONS-LESSP. This canonicalizes the PV-TABLEs a bit and 519;;; will hopefully lead to having fewer PVs floating around. Even if 520;;; the gain is only modest, it costs nothing. 521(defun slot-name-lists-from-slots (slots) 522 (mapcar (lambda (parameter-entry) 523 (when (cdr parameter-entry) 524 (mapcar #'car (cdr parameter-entry)))) 525 (mutate-slots slots))) 526 527(defun mutate-slots (slots) 528 (let ((sorted-slots (sort-slots slots)) 529 (pv-offset -1)) 530 (dolist (parameter-entry sorted-slots) 531 (dolist (slot-entry (cdr parameter-entry)) 532 (incf pv-offset) 533 (dolist (form (cdr slot-entry)) 534 (setf (cadr form) pv-offset)) 535 ;; Count one more for the slot we use for SLOT-INFO. 536 (incf pv-offset))) 537 sorted-slots)) 538 539(defun symbol-or-cons-lessp (a b) 540 (etypecase a 541 (symbol (etypecase b 542 (symbol (< (symbol-hash a) (symbol-hash b))) 543 (cons t))) 544 (cons (etypecase b 545 (symbol nil) 546 (cons (if (eq (car a) (car b)) 547 (symbol-or-cons-lessp (cdr a) (cdr b)) 548 (symbol-or-cons-lessp (car a) (car b)))))))) 549 550(defun sort-slots (slots) 551 (mapcar (lambda (parameter-entry) 552 (destructuring-bind (name . entries) parameter-entry 553 (cons name (stable-sort entries #'symbol-or-cons-lessp 554 :key #'car)))) 555 slots)) 556 557 558;;;; This needs to work in terms of metatypes and also needs to work 559;;;; for automatically generated reader and writer functions. 560;;;; Automatically generated reader and writer functions use this 561;;;; stuff too. 562 563(defmacro pv-binding ((required-parameters slot-name-lists pv-table-form) 564 &body body) 565 (let (slot-vars pv-parameters) 566 (loop for slots in slot-name-lists 567 for required-parameter in required-parameters 568 for i from 0 569 do (when slots 570 (push required-parameter pv-parameters) 571 (push (slot-vector-symbol i) slot-vars))) 572 `(pv-binding1 (,pv-table-form 573 ,(nreverse pv-parameters) ,(nreverse slot-vars)) 574 ,@body))) 575 576(defmacro pv-binding1 ((pv-table-form pv-parameters slot-vars) 577 &body body) 578 `(pv-env (,pv-table-form ,pv-parameters) 579 (let (,@(mapcar (lambda (slot-var p) `(,slot-var (get-slots-or-nil ,p))) 580 slot-vars pv-parameters)) 581 (declare (ignorable ,@(mapcar #'identity slot-vars))) 582 ,@body))) 583 584;;; This will only be visible in PV-ENV when the default MAKE-METHOD-LAMBDA is 585;;; overridden. 586(define-symbol-macro pv-env-environment overridden) 587 588(defmacro pv-env (&environment env 589 (pv-table-form pv-parameters) 590 &rest forms) 591 ;; Decide which expansion to use based on the state of the PV-ENV-ENVIRONMENT 592 ;; symbol-macrolet. 593 (if (eq (macroexpand 'pv-env-environment env) 'default) 594 `(locally (declare (simple-vector .pv.)) 595 ,@forms) 596 `(let* ((.pv-table. ,pv-table-form) 597 (.pv. (pv-table-lookup-pv-args .pv-table. ,@pv-parameters))) 598 (declare ,(make-pv-type-declaration '.pv.)) 599 ,@forms))) 600 601(defun split-declarations (body args req-args cnm-p parameters-setqd) 602 (let ((inner-decls nil) 603 (outer-decls nil) 604 decl) 605 (loop 606 (when (null body) 607 (return nil)) 608 (setq decl (car body)) 609 (unless (and (consp decl) (eq (car decl) 'declare)) 610 (return nil)) 611 (dolist (form (cdr decl)) 612 (when (consp form) 613 (let* ((name (car form))) 614 (cond ((eq '%class name) 615 (push `(declare ,form) inner-decls)) 616 ((or (member name '(ignore ignorable special dynamic-extent type)) 617 (info :type :kind name)) 618 (let* ((inners nil) 619 (outers nil) 620 (tail (cdr form)) 621 (head (if (eq 'type name) 622 (list name (pop tail)) 623 (list name)))) 624 (dolist (var tail) 625 (if (member var args :test #'eq) 626 ;; Quietly remove IGNORE declarations on 627 ;; args when a next-method is involved, to 628 ;; prevent compiler warnings about ignored 629 ;; args being read. 630 (unless (and (eq 'ignore name) 631 (member var req-args :test #'eq) 632 (or cnm-p (member var parameters-setqd))) 633 (push var outers)) 634 (push var inners))) 635 (when outers 636 (push `(declare (,@head ,@outers)) outer-decls)) 637 (when inners 638 (push `(declare (,@head ,@inners)) inner-decls)))) 639 (t 640 ;; All other declarations are not variable declarations, 641 ;; so they become outer declarations. 642 (push `(declare ,form) outer-decls)))))) 643 (setq body (cdr body))) 644 (values outer-decls inner-decls body))) 645 646;;; Convert a lambda expression containing a SB-PCL::%METHOD-NAME 647;;; declaration (which is a naming style internal to PCL) into an 648;;; SB-INT:NAMED-LAMBDA expression (which is a naming style used 649;;; throughout SBCL, understood by the main compiler); or if there's 650;;; no SB-PCL::%METHOD-NAME declaration, then just return the original 651;;; lambda expression. 652(defun name-method-lambda (method-lambda) 653 (let ((method-name *method-name*)) 654 (if method-name 655 `(named-lambda (slow-method ,@method-name) ,@(rest method-lambda)) 656 method-lambda))) 657 658(defun make-method-initargs-form-internal (method-lambda initargs env) 659 (declare (ignore env)) 660 (let (method-lambda-args 661 lmf ; becomes body of function 662 lmf-params) 663 (if (not (and (= 3 (length method-lambda)) 664 (= 2 (length (setq method-lambda-args (cadr method-lambda)))) 665 (consp (setq lmf (third method-lambda))) 666 (eq 'simple-lexical-method-functions (car lmf)) 667 (eq (car method-lambda-args) 668 (cadr (setq lmf-params (cadr lmf)))) 669 (eq (cadr method-lambda-args) 670 (caddr lmf-params)))) 671 `(list* :function ,(name-method-lambda method-lambda) 672 ',initargs) 673 (let* ((lambda-list (car lmf-params)) 674 (nreq 0) 675 (restp nil) 676 (args nil)) 677 (dolist (arg lambda-list) 678 (when (member arg '(&optional &rest &key)) 679 (setq restp t) 680 (return nil)) 681 (when (eq arg '&aux) 682 (return nil)) 683 (incf nreq) 684 (push arg args)) 685 (setq args (nreverse args)) 686 (setf (getf (getf initargs 'plist) :arg-info) (cons nreq restp)) 687 (make-method-initargs-form-internal1 688 initargs (cddr lmf) args lmf-params restp))))) 689 690(defun lambda-list-parameter-names (lambda-list) 691 ;; Given a valid lambda list, extract the parameter names. 692 (loop for x in lambda-list 693 with res = nil 694 do (unless (member x lambda-list-keywords :test #'eq) 695 (if (consp x) 696 (let ((name (car x))) 697 (if (consp name) 698 ;; ... ((:BAR FOO) 1) 699 (push (second name) res) 700 ;; ... (FOO 1) 701 (push name res)) 702 ;; ... (... 1 FOO-P) 703 (let ((name-p (cddr x))) 704 (when name-p 705 (push (car name-p) res)))) 706 ;; ... FOO 707 (push x res))) 708 finally (return res))) 709 710(defun make-method-initargs-form-internal1 711 (initargs body req-args lmf-params restp) 712 (let* (;; The lambda-list of the method, minus specifiers 713 (lambda-list (car lmf-params)) 714 ;; Names of the parameters that will be in the outermost lambda-list 715 ;; (and whose bound declarations thus need to be in OUTER-DECLS). 716 (outer-parameters req-args) 717 ;; The lambda-list used by BIND-ARGS 718 (bind-list lambda-list) 719 (parameters-setqd (getf (cdr lmf-params) :parameters-setqd)) 720 (auxp (member '&aux bind-list)) 721 (call-next-method-p (getf (cdr lmf-params) :call-next-method-p))) 722 ;; Try to use the normal function call machinery instead of BIND-ARGS 723 ;; binding the arguments, unless: 724 (unless (or ;; If all arguments are required, BIND-ARGS will be a no-op 725 ;; in any case. 726 (and (not restp) (not auxp)) 727 ;; CALL-NEXT-METHOD wants to use BIND-ARGS, and needs a 728 ;; list of all non-required arguments. 729 call-next-method-p) 730 (setf ;; We don't want a binding for .REST-ARG. 731 restp nil 732 ;; Get all the parameters for declaration parsing 733 outer-parameters (lambda-list-parameter-names lambda-list) 734 ;; Ensure that BIND-ARGS won't do anything (since 735 ;; BIND-LIST won't contain any non-required parameters, 736 ;; and REQ-ARGS will be of an equal length). We still want 737 ;; to pass BIND-LIST to FAST-LEXICAL-METHOD-FUNCTIONS so 738 ;; that BIND-FAST-LEXICAL-METHOD-FUNCTIONS can take care 739 ;; of rebinding SETQd required arguments around the method 740 ;; body. 741 bind-list req-args)) 742 (multiple-value-bind (outer-decls inner-decls body-sans-decls) 743 (split-declarations 744 body outer-parameters req-args call-next-method-p parameters-setqd) 745 (let* ((rest-arg (when restp 746 '.rest-arg.)) 747 (fmf-lambda-list (if rest-arg 748 (append req-args (list '&rest rest-arg)) 749 (if call-next-method-p 750 req-args 751 lambda-list)))) 752 `(list* 753 :function 754 (let* ((fmf (,(if *method-name* 'named-lambda 'lambda) 755 ,@(when *method-name* 756 ;; function name 757 (list `(fast-method ,@*method-name*))) 758 ;; The lambda-list of the FMF 759 (.pv. .next-method-call. ,@fmf-lambda-list) 760 ;; body of the function 761 (declare (ignorable .pv. .next-method-call.) 762 (disable-package-locks pv-env-environment)) 763 ,@outer-decls 764 (symbol-macrolet ((pv-env-environment default)) 765 (fast-lexical-method-functions 766 (,bind-list .next-method-call. ,req-args ,rest-arg 767 ,@(cdddr lmf-params)) 768 ,@inner-decls 769 ,@body-sans-decls)))) 770 (mf (%make-method-function fmf nil))) 771 (set-funcallable-instance-function 772 mf (method-function-from-fast-function fmf ',(getf initargs 'plist))) 773 mf) 774 ',initargs))))) 775 776;;; Use arrays and hash tables and the fngen stuff to make this much 777;;; better. It doesn't really matter, though, because a function 778;;; returned by this will get called only when the user explicitly 779;;; funcalls a result of method-function. BUT, this is needed to make 780;;; early methods work. 781(defun method-function-from-fast-function (fmf plist) 782 (declare (type function fmf)) 783 (let* ((method-function nil) 784 (snl (getf plist :slot-name-lists)) 785 (pv-table (when snl 786 (intern-pv-table :slot-name-lists snl)))) 787 (setq method-function 788 (lambda (method-args next-methods) 789 (let* ((pv (when pv-table 790 (get-pv method-args pv-table))) 791 (nm (car next-methods)) 792 (nms (cdr next-methods)) 793 (nmc (when nm 794 (make-method-call 795 :function (if (std-instance-p nm) 796 (method-function nm) 797 nm) 798 :call-method-args (list nms))))) 799 (apply fmf pv nmc method-args)))) 800 ;; FIXME: this looks dangerous. 801 (let* ((fname (%fun-name fmf))) 802 (when (and fname (eq (car fname) 'fast-method)) 803 (set-fun-name method-function (cons 'slow-method (cdr fname))))) 804 method-function)) 805 806;;; this is similar to the above, only not quite. Only called when 807;;; the MOP is heavily involved. Not quite parallel to 808;;; METHOD-FUNCTION-FROM-FAST-METHOD-FUNCTION, because we can close 809;;; over the actual PV-CELL in this case. 810(defun method-function-from-fast-method-call (fmc) 811 (let* ((fmf (fast-method-call-function fmc)) 812 (pv (fast-method-call-pv fmc))) 813 (lambda (method-args next-methods) 814 (let* ((nm (car next-methods)) 815 (nms (cdr next-methods)) 816 (nmc (when nm 817 (make-method-call 818 :function (if (std-instance-p nm) 819 (method-function nm) 820 nm) 821 :call-method-args (list nms))))) 822 (apply fmf pv nmc method-args))))) 823 824(defun get-pv (method-args pv-table) 825 (let ((pv-wrappers (pv-wrappers-from-all-args pv-table method-args))) 826 (when pv-wrappers 827 (pv-table-lookup pv-table pv-wrappers)))) 828 829(defun pv-table-lookup-pv-args (pv-table &rest pv-parameters) 830 (pv-table-lookup pv-table (pv-wrappers-from-pv-args pv-parameters))) 831 832(defun pv-wrappers-from-pv-args (&rest args) 833 (mapcar #'valid-wrapper-of args)) 834 835(defun pv-wrappers-from-all-args (pv-table args) 836 (loop for snl in (pv-table-slot-name-lists pv-table) 837 and arg in args 838 when snl 839 collect (valid-wrapper-of arg))) 840 841;;; Return the subset of WRAPPERS which is used in the cache 842;;; of PV-TABLE. 843(defun pv-wrappers-from-all-wrappers (pv-table wrappers) 844 (loop for snl in (pv-table-slot-name-lists pv-table) 845 and w in wrappers 846 when snl 847 collect w)) 848