X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fpcl%2Fcompiler-support.lisp;h=cec722eeab5be7f6b64c4d7aca6124deef026cb2;hb=2bb123efd9f1566b2bff388b55d57698a69b69ba;hp=f7da5091ae67b2b11812ad6d12cd714415fa48b4;hpb=c593dc26733b179db6c12c7085ed76b762ac256b;p=sbcl.git diff --git a/src/pcl/compiler-support.lisp b/src/pcl/compiler-support.lisp index f7da509..cec722e 100644 --- a/src/pcl/compiler-support.lisp +++ b/src/pcl/compiler-support.lisp @@ -84,45 +84,11 @@ (valid-function-name-p (cadr list))) (define-internal-pcl-function-name-syntax sb-pcl::ctor (list) - (valid-function-name-p (cadr list))) - -;;;; SLOT-VALUE optimizations - -(defknown slot-value (t symbol) t (any)) -(defknown sb-pcl::set-slot-value (t symbol t) t (any)) - -(defun pcl-boot-state-complete-p () - (eq 'sb-pcl::complete sb-pcl::*boot-state*)) - -;;; These essentially duplicate what the compiler-macros in slots.lisp -;;; do, but catch more cases. We retain the compiler-macros since they -;;; can be used during the build, and because they catch common cases -;;; slightly more cheaply then the transforms. (Transforms add new -;;; lambdas, which requires more work by the compiler.) - -(deftransform slot-value ((object slot-name)) - "optimize" - (let (c-slot-name) - (if (and (pcl-boot-state-complete-p) - (constant-lvar-p slot-name) - (setf c-slot-name (lvar-value slot-name)) - (sb-pcl::interned-symbol-p c-slot-name)) - `(sb-pcl::accessor-slot-value object ',c-slot-name) - (give-up-ir1-transform "Slot name is not constant.")))) + (let ((class-or-name (cadr list))) + (cond + ((symbolp class-or-name) + (values (valid-function-name-p class-or-name) nil)) + ((or (sb-pcl::std-instance-p class-or-name) + (sb-pcl::fsc-instance-p class-or-name)) + (values t nil))))) -(deftransform sb-pcl::set-slot-value ((object slot-name new-value) - (t symbol t) t - ;; Safe code wants to check the - ;; type, and the global accessor - ;; won't do that. Also see the - ;; comment in the - ;; compiler-macro. - :policy (< safety 3)) - "optimize" - (let (c-slot-name) - (if (and (pcl-boot-state-complete-p) - (constant-lvar-p slot-name) - (setf c-slot-name (lvar-value slot-name)) - (sb-pcl::interned-symbol-p c-slot-name)) - `(sb-pcl::accessor-set-slot-value object ',c-slot-name new-value) - (give-up-ir1-transform "Slot name is not constant."))))