1.0.16.17: log bug #426: inlining failure involing multiple nested calls
[sbcl/tcr.git] / src / pcl / compiler-support.lisp
blobe00deee1111d1498d278580d633b2dd0ed0a8d8e
1 ;;;; things which the main SBCL compiler needs to know about the
2 ;;;; implementation of CLOS
3 ;;;;
4 ;;;; (Our CLOS is derived from PCL, which was implemented in terms of
5 ;;;; portable high-level Common Lisp. But now that it no longer needs
6 ;;;; to be portable, we can make some special hacks to support it
7 ;;;; better.)
9 ;;;; This software is part of the SBCL system. See the README file for more
10 ;;;; information.
12 ;;;; This software is derived from software originally released by Xerox
13 ;;;; Corporation. Copyright and release statements follow. Later modifications
14 ;;;; to the software are in the public domain and are provided with
15 ;;;; absolutely no warranty. See the COPYING and CREDITS files for more
16 ;;;; information.
18 ;;;; copyright information from original PCL sources:
19 ;;;;
20 ;;;; Copyright (c) 1985, 1986, 1987, 1988, 1989, 1990 Xerox Corporation.
21 ;;;; All rights reserved.
22 ;;;;
23 ;;;; Use and copying of this software and preparation of derivative works based
24 ;;;; upon this software are permitted. Any distribution of this software or
25 ;;;; derivative works must comply with all applicable United States export
26 ;;;; control laws.
27 ;;;;
28 ;;;; This software is made available AS IS, and Xerox Corporation makes no
29 ;;;; warranty about the software, its performance or its conformity to any
30 ;;;; specification.
32 (in-package "SB-C")
34 ;;;; very low-level representation of instances with meta-class
35 ;;;; STANDARD-CLASS
37 (defknown sb-pcl::pcl-instance-p (t) boolean
38 (movable foldable flushable explicit-check))
40 (deftransform sb-pcl::pcl-instance-p ((object))
41 (let* ((otype (lvar-type object))
42 (standard-object (specifier-type 'standard-object)))
43 (cond
44 ;; Flush tests whose result is known at compile time.
45 ((csubtypep otype standard-object) t)
46 ((not (types-equal-or-intersect otype standard-object)) nil)
48 `(typep (layout-of object) 'sb-pcl::wrapper)))))
50 (defun sb-pcl::safe-code-p (&optional env)
51 (let* ((lexenv (or env (make-null-lexenv)))
52 (policy (lexenv-policy lexenv)))
53 (eql (cdr (assoc 'safety policy)) 3)))
55 (define-source-context defmethod (name &rest stuff)
56 (let ((arg-pos (position-if #'listp stuff)))
57 (if arg-pos
58 `(defmethod ,name ,@(subseq stuff 0 arg-pos)
59 ,(handler-case
60 (nth-value 2 (sb-pcl::parse-specialized-lambda-list
61 (elt stuff arg-pos)))
62 (error () "<illegal syntax>")))
63 `(defmethod ,name "<illegal syntax>"))))
65 (defvar sb-pcl::*internal-pcl-generalized-fun-name-symbols* nil)
67 (defmacro define-internal-pcl-function-name-syntax (name &body body)
68 `(progn
69 (define-function-name-syntax ,name ,@body)
70 (pushnew ',name sb-pcl::*internal-pcl-generalized-fun-name-symbols*)))
72 (define-internal-pcl-function-name-syntax sb-pcl::slot-accessor (list)
73 (when (= (length list) 4)
74 (destructuring-bind (class slot rwb) (cdr list)
75 (when (and (member rwb '(sb-pcl::reader sb-pcl::writer sb-pcl::boundp))
76 (symbolp slot)
77 (symbolp class))
78 (values t slot)))))
80 (define-internal-pcl-function-name-syntax sb-pcl::fast-method (list)
81 (valid-function-name-p (cadr list)))
83 (define-internal-pcl-function-name-syntax sb-pcl::slow-method (list)
84 (valid-function-name-p (cadr list)))
86 (define-internal-pcl-function-name-syntax sb-pcl::ctor (list)
87 (valid-function-name-p (cadr list)))
89 (defun sb-pcl::random-documentation (name type)
90 (cdr (assoc type (info :random-documentation :stuff name))))
92 (defun sb-pcl::set-random-documentation (name type new-value)
93 (let ((pair (assoc type (info :random-documentation :stuff name))))
94 (if pair
95 (setf (cdr pair) new-value)
96 (push (cons type new-value)
97 (info :random-documentation :stuff name))))
98 new-value)
100 (defsetf sb-pcl::random-documentation sb-pcl::set-random-documentation)
102 ;;;; SLOT-VALUE optimizations
104 (defknown slot-value (t symbol) t (any))
105 (defknown sb-pcl::set-slot-value (t symbol t) t (any))
107 (defun pcl-boot-state-complete-p ()
108 (eq 'sb-pcl::complete sb-pcl::*boot-state*))
110 ;;; These essentially duplicate what the compiler-macros in slots.lisp
111 ;;; do, but catch more cases. We retain the compiler-macros since they
112 ;;; can be used during the build, and because they catch common cases
113 ;;; slightly more cheaply then the transforms. (Transforms add new
114 ;;; lambdas, which requires more work by the compiler.)
116 (deftransform slot-value ((object slot-name))
117 "optimize"
118 (let (c-slot-name)
119 (if (and (pcl-boot-state-complete-p)
120 (constant-lvar-p slot-name)
121 (setf c-slot-name (lvar-value slot-name))
122 (sb-pcl::interned-symbol-p c-slot-name))
123 `(sb-pcl::accessor-slot-value object ',c-slot-name)
124 (give-up-ir1-transform "Slot name is not constant."))))
126 (deftransform sb-pcl::set-slot-value ((object slot-name new-value)
127 (t symbol t) t
128 ;; Safe code wants to check the
129 ;; type, and the global accessor
130 ;; won't do that. Also see the
131 ;; comment in the
132 ;; compiler-macro.
133 :policy (< safety 3))
134 "optimize"
135 (let (c-slot-name)
136 (if (and (pcl-boot-state-complete-p)
137 (constant-lvar-p slot-name)
138 (setf c-slot-name (lvar-value slot-name))
139 (sb-pcl::interned-symbol-p c-slot-name))
140 `(sb-pcl::accessor-set-slot-value object ',c-slot-name new-value)
141 (give-up-ir1-transform "Slot name is not constant."))))