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 ;; Return the full lambda list, the required arguments, a form 67 ;; that will generate a rest-list, and a list of the &MORE 68 ;; parameters used. 69 ;; Beware of deep voodoo! The DEFKNOWN for %LISTIFY-REST-ARGS says that its 70 ;; second argument is INDEX, but the THE form below is "weaker" on account 71 ;; of the vop operand restrictions or something that I don't understand. 72 ;; Which is to say, PCL compilation reliably broke when changed to INDEX. 73 (if applyp 74 (values (append required '(&more .more-context. .more-count.)) 75 required 76 '((sb-c:%listify-rest-args 77 .more-context. (the (and unsigned-byte fixnum) 78 .more-count.))) 79 '(.more-context. .more-count.)) 80 (values required required nil nil)))) 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 ; See above re. voodoo 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. '.next-method-call. (make-dfun-lambda-list nargs applyp))) 105 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 165(defun emit-default-only (metatypes applyp) 166 (multiple-value-bind (lambda-list args rest-arg more-arg) 167 (make-dlap-lambda-list (length metatypes) applyp) 168 (generating-lisp '(emf) 169 lambda-list 170 `(invoke-effective-method-function emf 171 ,applyp 172 :required-args ,args 173 :more-arg ,more-arg 174 :rest-arg ,rest-arg)))) 175 176;;; -------------------------------- 177 178(defun generating-lisp (closure-variables args form) 179 (let ((lambda `(lambda ,closure-variables 180 ,@(when (member 'miss-fn closure-variables) 181 `((declare (type function miss-fn)))) 182 #'(lambda ,args 183 (let () 184 (declare #.*optimize-speed*) 185 ,form))))) 186 (values (if *precompiling-lap* 187 `#',lambda 188 (compile nil lambda)) 189 nil))) 190 191;;; note on implementation for CMU 17 and later (including SBCL): 192;;; Since STD-INSTANCE-P is weakened, that branch may run on non-PCL 193;;; instances (structures). The result will be the non-wrapper layout 194;;; for the structure, which will cause a miss. The "slots" will be 195;;; whatever the first slot is, but will be ignored. Similarly, 196;;; FSC-INSTANCE-P returns true on funcallable structures as well as 197;;; PCL fins. 198(defun emit-reader/writer (reader/writer 1-or-2-class class-slot-p) 199 (let ((instance nil) 200 (arglist ()) 201 (closure-variables ()) 202 (read-form (emit-slot-read-form class-slot-p 'index 'slots))) 203 (ecase reader/writer 204 ((:reader :boundp) 205 (setq instance (dfun-arg-symbol 0) 206 arglist (list instance))) 207 (:writer (setq instance (dfun-arg-symbol 1) 208 arglist (list (dfun-arg-symbol 0) instance)))) 209 (ecase 1-or-2-class 210 (1 (setq closure-variables '(wrapper-0 index miss-fn))) 211 (2 (setq closure-variables '(wrapper-0 wrapper-1 index miss-fn)))) 212 (generating-lisp 213 closure-variables 214 arglist 215 `(let* (,@(unless class-slot-p `((slots nil))) 216 (wrapper (cond ((std-instance-p ,instance) 217 ,@(unless class-slot-p 218 `((setq slots 219 (std-instance-slots ,instance)))) 220 (std-instance-wrapper ,instance)) 221 ((fsc-instance-p ,instance) 222 ,@(unless class-slot-p 223 `((setq slots 224 (fsc-instance-slots ,instance)))) 225 (fsc-instance-wrapper ,instance))))) 226 (block access 227 (when (and wrapper 228 (not (zerop (layout-clos-hash wrapper))) 229 ,@(if (eql 1 1-or-2-class) 230 `((eq wrapper wrapper-0)) 231 `((or (eq wrapper wrapper-0) 232 (eq wrapper wrapper-1))))) 233 ,@(ecase reader/writer 234 (:reader 235 `((let ((value ,read-form)) 236 (unless (eq value +slot-unbound+) 237 (return-from access value))))) 238 (:boundp 239 `((let ((value ,read-form)) 240 (return-from access (not (eq value +slot-unbound+)))))) 241 (:writer 242 `((return-from access (setf ,read-form ,(car arglist))))))) 243 (funcall miss-fn ,@arglist)))))) 244 245(defun emit-slot-read-form (class-slot-p index slots) 246 (if class-slot-p 247 `(cdr ,index) 248 `(clos-slots-ref ,slots ,index))) 249 250(defun emit-boundp-check (value-form miss-fn arglist) 251 `(let ((value ,value-form)) 252 (if (eq value +slot-unbound+) 253 (funcall ,miss-fn ,@arglist) 254 value))) 255 256(defun emit-slot-access (reader/writer class-slot-p slots 257 index miss-fn arglist) 258 (let ((read-form (emit-slot-read-form class-slot-p index slots))) 259 (ecase reader/writer 260 (:reader (emit-boundp-check read-form miss-fn arglist)) 261 (:boundp `(not (eq ,read-form +slot-unbound+))) 262 (:writer `(setf ,read-form ,(car arglist)))))) 263 264(defmacro emit-reader/writer-macro (reader/writer 1-or-2-class class-slot-p) 265 (let ((*precompiling-lap* t)) 266 (values 267 (emit-reader/writer reader/writer 1-or-2-class class-slot-p)))) 268 269;; If CACHED-INDEX-P is false, then the slot location is a constant and 270;; the cache holds layouts eligible to use that index. 271;; If true, then the cache is a map of layout -> index. 272(defun emit-one-or-n-index-reader/writer (reader/writer 273 cached-index-p 274 class-slot-p) 275 (multiple-value-bind (arglist metatypes) 276 (ecase reader/writer 277 ((:reader :boundp) 278 (values (list (dfun-arg-symbol 0)) 279 '(standard-instance))) 280 (:writer (values (list (dfun-arg-symbol 0) (dfun-arg-symbol 1)) 281 '(t standard-instance)))) 282 (generating-lisp 283 `(cache ,@(unless cached-index-p '(index)) miss-fn) 284 arglist 285 `(let (,@(unless class-slot-p '(slots)) 286 ,@(when cached-index-p '(index))) 287 ,(emit-dlap 'cache arglist metatypes 288 (emit-slot-access reader/writer class-slot-p 289 'slots 'index 'miss-fn arglist) 290 `(funcall miss-fn ,@arglist) 291 (when cached-index-p 'index) 292 (unless class-slot-p '(slots))))))) 293 294(defmacro emit-one-or-n-index-reader/writer-macro 295 (reader/writer cached-index-p class-slot-p) 296 (let ((*precompiling-lap* t)) 297 (values 298 (emit-one-or-n-index-reader/writer reader/writer 299 cached-index-p 300 class-slot-p)))) 301 302(defun emit-miss (miss-fn args applyp) 303 (if applyp 304 `(multiple-value-call ,miss-fn ,@args 305 (sb-c::%more-arg-values .more-context. 306 0 307 .more-count.)) 308 `(funcall ,miss-fn ,@args))) 309 310;; (cache-emf, return-value): 311;; NIL / NIL : GF has a single EMF. Invoke it when layouts are in cache. 312;; NIL / T : GF has a single EMF. Return T when layouts are in cache. 313;; T / NIL : Look for the EMF for argument layouts. Invoke it when in cache. 314;; T / T : Look for the EMF for argument layouts. Return it when in cache. 315;; 316;; METATYPES must be acceptable to EMIT-FETCH-WRAPPER. 317;; APPLYP says whether there is a &MORE context. 318(defun emit-checking-or-caching (cached-emf-p return-value-p metatypes applyp) 319 (multiple-value-bind (lambda-list args rest-arg more-arg) 320 (make-dlap-lambda-list (length metatypes) applyp) 321 (generating-lisp 322 `(cache ,@(unless cached-emf-p '(emf)) miss-fn) 323 lambda-list 324 `(let (,@(when cached-emf-p '(emf))) 325 ,(emit-dlap 'cache args metatypes 326 (if return-value-p 327 (if cached-emf-p 'emf t) 328 `(invoke-effective-method-function 329 emf ,applyp 330 :required-args ,args 331 :more-arg ,more-arg 332 :rest-arg ,rest-arg)) 333 (emit-miss 'miss-fn args applyp) 334 (when cached-emf-p 'emf)))))) 335 336(defmacro emit-checking-or-caching-macro (cached-emf-p 337 return-value-p 338 metatypes 339 applyp) 340 (let ((*precompiling-lap* t)) 341 (values 342 (emit-checking-or-caching cached-emf-p return-value-p metatypes applyp)))) 343 344(defun emit-dlap (cache-var args metatypes hit-form miss-form value-var 345 &optional slot-vars) 346 (let* ((index -1) 347 (miss-tag (gensym "MISSED")) 348 (wrapper-bindings (mapcan (lambda (arg mt) 349 (unless (eq mt t) 350 (incf index) 351 `((,(format-symbol *pcl-package* 352 "WRAPPER-~D" 353 index) 354 ,(emit-fetch-wrapper 355 mt arg miss-tag (pop slot-vars)))))) 356 args metatypes)) 357 (wrapper-vars (mapcar #'car wrapper-bindings))) 358 (declare (fixnum index)) 359 (unless wrapper-vars 360 (error "Every metatype is T.")) 361 `(prog () 362 (return 363 (let ,wrapper-bindings 364 ,(emit-cache-lookup cache-var wrapper-vars miss-tag value-var) 365 ,hit-form)) 366 ,miss-tag 367 (return ,miss-form)))) 368 369;; SLOTS-VAR, if supplied, is the variable to update with instance-slots 370;; by side-effect of fetching the wrapper for ARGUMENT. 371(defun emit-fetch-wrapper (metatype argument miss-tag &optional slots-var) 372 (ecase metatype 373 ((standard-instance) 374 ;; This branch may run on non-pcl instances (structures). The 375 ;; result will be the non-wrapper layout for the structure, which 376 ;; will cause a miss. Since refencing the structure is rather iffy 377 ;; if it should have no slots, or only raw slots, we use FOR-STD-CLASS-P 378 ;; to ensure that we have a wrapper. 379 ;; 380 ;; FIXME: If we unify layouts and wrappers we can use 381 ;; instance-slots-layout instead of for-std-class-p, as if there 382 ;; are no layouts there are no slots to worry about. 383 (with-unique-names (wrapper) 384 `(cond ((std-instance-p ,argument) 385 ,(if slots-var 386 `(let ((,wrapper (std-instance-wrapper ,argument))) 387 (when (layout-for-std-class-p ,wrapper) 388 (setq ,slots-var (std-instance-slots ,argument))) 389 ,wrapper) 390 `(std-instance-wrapper ,argument))) 391 ((fsc-instance-p ,argument) 392 ,(if slots-var 393 `(let ((,wrapper (fsc-instance-wrapper ,argument))) 394 (when (layout-for-std-class-p ,wrapper) 395 (setq ,slots-var (fsc-instance-slots ,argument))) 396 ,wrapper) 397 `(fsc-instance-wrapper ,argument))) 398 (t (go ,miss-tag))))) 399 ;; Sep92 PCL used to distinguish between some of these cases (and 400 ;; spuriously exclude others). Since in SBCL 401 ;; WRAPPER-OF/LAYOUT-OF/BUILT-IN-OR-STRUCTURE-WRAPPER are all 402 ;; equivalent and inlined to each other, we can collapse some 403 ;; spurious differences. 404 ((class system-instance structure-instance condition-instance) 405 (when slots-var 406 (bug "SLOT requested for metatype ~S, but it isn't going to happen." 407 metatype)) 408 `(layout-of ,argument)) 409 ;; a metatype of NIL should never be seen here, as NIL is only in 410 ;; the metatypes before a generic function is fully initialized. 411 ;; T should never be seen because we never need to get a wrapper 412 ;; to do dispatch if all methods have T as the respective 413 ;; specializer. 414 ((t nil) 415 (bug "~@<metatype ~S seen in ~S.~@:>" metatype 'emit-fetch-wrapper)))) 416