Funnel COMPILE calls in CLOS through a wrapper function

This simplifies rebinding of the warning and note muffler, and allows
tracing or otherwise intercepting system-generated compilation.

Also: gensym is considered harmful. I'm noticing tons of compilations
to the identical lambda, and it's a lot easier to figure out why
without having to think about symbols that differ for no good reason.
(I suspect that if N threads all need to invoke a GF for the first time
at about the same time, they'll all cache miss, and then all compile
the identical dfun. This is horrible and is need of good solution)

src/compiler/policy.lisp

@@ -286,6 +286,13 @@ See also :POLICY option in WITH-COMPILATION-UNIT."
   ;; can create a POLICY that indicates absence of primary qualities.
   ;; This does not affect RESTRICT-COMPILER-POLICY because a lower bound of 0
   ;; can be assumed for everything. SET-MACRO-POLICY might care though.
+  ;;
+  ;; FIXME: it is wrong IMHO that the min/max are applied lazily, every time
+  ;; they are fetched from a policy. This makes it impossible to create
+  ;; a policy that represents _exactly_ what you want in the internals of the
+  ;; CLOS implementation. Applying the min/max when a policy is created would
+  ;; provide an escape mechanism. Alternatively we could indicate in the policy
+  ;; whether each quality should be treated as absolute.
   (define-getter %policy-quality
     (let ((min *policy-min*)
           (max *policy-max*))

src/pcl/cache.lisp

@@ -124,7 +124,7 @@
 
 ;;; Return VALUE if it is not the unbound marker, otherwise executes ELSE:
 (defmacro non-empty-or (value else)
-  (with-unique-names (n-value)
+  (let ((n-value '#:val))
     `(let ((,n-value ,value))
        (if (unbound-marker-p ,n-value)
            ,else
@@ -197,12 +197,19 @@
 ;;; In other words, produces inlined code for COMPUTE-CACHE-INDEX when
 ;;; number of keys and presence of values in the cache is known
 ;;; beforehand.
+(defglobal *hash-vars*
+  (make-array 6 :initial-contents
+              (loop for i from 0 below 6 collect (make-symbol (format nil "H~D" i)))))
 (defun emit-cache-lookup (cache-var layout-vars miss-tag value-var)
   (declare (muffle-conditions code-deletion-note))
-  (with-unique-names (probe n-vector n-depth n-mask
+  (multiple-value-bind (probe n-vector n-depth n-mask
                       MATCH-WRAPPERS EXIT-WITH-HIT)
+      (values '#:probe '#:vect '#:depth '#:mask '#:try '#:hit)
     (let* ((num-keys (length layout-vars))
-           (hash-vars (make-gensym-list num-keys))
+           (hash-vars (loop for i from 0 below num-keys
+                            collect (if (< i #.(length *hash-vars*))
+                                        (aref *hash-vars* i)
+                                        (make-symbol (format nil "H~D" i)))))
            (pointer
             ;; We don't need POINTER if the cache has 1 key and no value,
             ;; or if FOLD-INDEX-ADDRESSING is supported, in which case adding
@@ -488,7 +495,7 @@
   cache)
 
 ;;; Copying a cache without expanding it is very much like mapping it:
-;;; we need to be carefull because there may be updates while we are
+;;; we need to be careful because there may be updates while we are
 ;;; copying it, and we don't want to copy incomplete entries or invalid
 ;;; ones.
 (defun copy-cache (cache)

src/pcl/call-next-method.lisp

@@ -188,7 +188,7 @@
                               (optimize (speed 3) (debug 0) (safety 0)))
                      ',result)
                   nil))
-         (function (compile nil lambda))
+         (function (pcl-compile lambda))
          (specializers (append (method-specializers (first orig-methods))
                                (method-specializers (first cnm-methods))))
          (method (make-instance 'standard-method

src/pcl/ctor.lisp

@@ -552,12 +552,9 @@
       (multiple-value-bind (form locations names optimizedp)
           (constructor-function-form ctor)
         (setf (%funcallable-instance-fun ctor)
-              (apply
-               (let ((*compiling-optimized-constructor* t))
-                 (handler-bind ((compiler-note #'muffle-warning))
-                   (compile nil `(lambda ,names (declare #.*optimize-speed*)
-                                   ,form))))
-               locations)
+              (apply (let ((*compiling-optimized-constructor* t))
+                       (pcl-compile `(lambda ,names ,form) t))
+                     locations)
               (ctor-state ctor) (if optimizedp 'optimized 'fallback))))))
 
 (defun install-optimized-allocator (ctor)
@@ -580,9 +577,7 @@
       (multiple-value-bind (form optimizedp)
           (allocator-function-form ctor)
         (setf (%funcallable-instance-fun ctor)
-              (let ((*compiling-optimized-constructor* t))
-                (handler-bind ((compiler-note #'muffle-warning))
-                  (compile nil form)))
+              (let ((*compiling-optimized-constructor* t)) (pcl-compile form t))
               (ctor-state ctor) (if optimizedp 'optimized 'fallback))))))
 
 (defun allocator-function-form (ctor)

src/pcl/dlisp.lisp

@@ -182,12 +182,12 @@
                    (declare (optimize (sb-c:store-source-form 0)))
                    (declare (optimize (sb-c::store-closure-debug-pointer 3)))
                    #'(lambda ,args
-                       (let ()
+                       (let () ; What is this LET doing?
                          (declare #.*optimize-speed*)
                          ,form)))))
     (values (if *precompiling-lap*
                 `#',lambda
-                (compile nil lambda))
+                (pcl-compile lambda))
             nil)))
 
 ;;; note on implementation for CMU 17 and later (including SBCL):

src/pcl/fngen.lisp

@@ -111,10 +111,9 @@
 (defun get-new-fun-generator (lambda test code-converter)
   (multiple-value-bind (code gensyms) (compute-code lambda code-converter)
     (let ((generator-lambda `(lambda ,gensyms
-                               (declare (muffle-conditions compiler-note)
-                                        (optimize (sb-c:store-source-form 0)))
+                               (declare (optimize (sb-c:store-source-form 0)))
                                (function ,code))))
-      (let ((generator (compile nil generator-lambda)))
+      (let ((generator (pcl-compile generator-lambda)))
         (ensure-fgen test gensyms generator generator-lambda nil)
         generator))))
 

src/pcl/init.lisp

@@ -91,8 +91,7 @@
        ;; The normal, good case: compile an efficient typecheck function.
        (let ((*typecheck-stack* (cons cookie *typecheck-stack*)))
          (handler-bind (((or style-warning compiler-note) #'muffle-warning))
-           (let ((fun (compile
-                       nil
+           (let ((fun (pcl-compile
                        `(named-lambda (slot-typecheck ,type) (value)
                           (declare (optimize (sb-c:store-coverage-data 0)
                                              (sb-c::type-check 3)

src/pcl/low.lisp

@@ -227,8 +227,6 @@
 ;;;; abstraction around our native structure representation doesn't
 ;;;; seem to add anything useful, and could probably go away.
 
-;;; The definition of STRUCTURE-TYPE-P was moved to early-low.lisp.
-
 (defun structure-type-slot-description-list (type)
   (let* ((dd (find-defstruct-description type))
          (include (dd-include dd))
@@ -281,7 +279,9 @@
 ;;; Damned-if-you-do / damned-if-you don't - the best thing would be to
 ;;; compile all accessors at "really" compile-time but not store the writer
 ;;; for a reaadonly slot under the #<fdefn> for #'(SETF slot-name).
-;;;
+;;; FIXME: this is highly obfuscated and we should just do exactly what the
+;;; preceding comment suggests: compile all slot-writer frobs and attach
+;;; them to the defstruct-definition in %TARGET-DEFSTRUCT.
 (defun structure-slotd-writer-function (type slotd)
   ;; TYPE is not used, because the DD is taken from runtime data.
   (declare (ignore type))
@@ -294,7 +294,7 @@
         (lambda (newval instance)
           (if (eql setter 0)
               (let* ((dd (wrapper-info (%instance-wrapper instance)))
-                     (f (compile nil (slot-setter-lambda-form dd slotd))))
+                     (f (pcl-compile (slot-setter-lambda-form dd slotd))))
                 (if (functionp f)
                     (funcall (setq setter f) newval instance)
                     (uninitialized-accessor-function :writer slotd)))
@@ -309,3 +309,19 @@
 
 (defun structure-slotd-init-form (slotd)
   (dsd-default slotd))
+
+(defun pcl-compile (expr &optional unsafe-policy)
+  (let* ((base-policy sb-c::*policy*)
+         (lexenv
+          (sb-c::make-almost-null-lexenv
+           (if unsafe-policy
+               (sb-c::process-optimize-decl
+                '((space 1) (compilation-speed 1)
+                  (speed 3) (safety 0) (sb-ext:inhibit-warnings 3) (debug 0))
+                base-policy)
+               base-policy)
+           ;; I suspect that INHIBIT-WARNINGS precludes them from happening
+           (list (cons (sb-kernel:find-classoid 'style-warning) 'muffle-warning)
+                 (cons (sb-kernel:find-classoid 'compiler-note) 'muffle-warning))
+           nil nil nil)))
+    (sb-c:compile-in-lexenv expr lexenv nil nil nil nil nil)))

src/pcl/precom2.lisp

@@ -34,13 +34,13 @@
 
 (push '("SB-PCL" *pcl-package* *built-in-classes*) *!removable-symbols*)
 
+(defun !system-class-p (x) (typep x 'sb-pcl::system-class))
+
 (let ((class (find-class 'sequence)))
   ;; Give the prototype a concrete prototype. It's an extra step because
   ;; SEQUENCE was removed from *built-in-classes*
   (setf (slot-value class 'prototype) #()))
-(dolist (c (sb-vm:list-allocated-objects
-            :all
-            :test (compile nil '(lambda (x) (typep x 'sb-pcl::system-class)))))
+(dolist (c (sb-vm:list-allocated-objects :all :test #'!system-class-p))
   (when (slot-boundp c 'sb-pcl::prototype)
     (let ((val (slot-value c 'sb-pcl::prototype)))
       (assert (typep val c)))))

tests/clos.impure-cload.lisp

@@ -186,10 +186,10 @@
     (call-next-method)))
 
 (defvar *compile-count* 0)
-(sb-int:encapsulate 'compile 'call-counter
-                    (lambda (f name thing)
+(sb-int:encapsulate 'sb-c:compile-in-lexenv 'call-counter
+                    (lambda (realfun &rest args)
                       (incf *compile-count*)
-                      (funcall f name thing)))
+                      (apply realfun args)))
 
 (defstruct mystruct-r/w (some-slot))
 (defstruct mystruct-r/o (allegedly-immutable-slot 3 :read-only t))