[Date Prev][Date Next][Thread Prev][Thread Next][Date Index][Thread Index]

compile-flavor-methods for CLOS



    Date: Mon, 17 Dec 1990 18:55 EST
    From: LRAK561@utxvms.cc.utexas.edu

    A few months ago I remember seeing a question on this bboard asking
    if something like compile-flavor-methods exists for CLOS, and I remember
    that the answer was No.  Do I remember correctly?  Is there something I
    can do in CLOS that will have the equivalent effect?

    I have an application which uses CLOS, and start-up time is slowed by
    what appears to be (in the lower right-hand corner) compilation of CLOS
    hierarchies.

    Thanks in advance for any help.

This question has been asked enough times that I think it's time for a
small public service announcement for those of you who use Genera and CLOE.

The first two functions below is what we use in CLIM to generate a form
that will arrange to prefill method dispatch caches at load-time.  The
way you use it is to (1) load your CLOS-based application, (2) run a
whole bunch of "representative" code, (3) fill in the <<A LIST OF CLASSES>>
list in GENERATE-ALL-PREFILL-DISPATCH-CACHES with the important classes
in your application, and then execute that function.  It will generate
(via GENERATE-PREFILL-DISPATCH-CACHES) a bunch of Lisp forms that, when
evaluated, will fill the dispatch caches.

The last two functions are the functions that actually prefill the dispatch
caches for the methods of a generic function.

Note well that these functions work only in Genera and CLOE.  Please don't
ask me to provide support for them either.  They are meant to guide people
who think that this is important.

----------------
(defun generate-all-prefill-dispatch-caches (&optional file)
  (if file
      (with-open-file (*standard-output* file :direction :output)
	(generate-all-prefill-dispatch-caches))
      (let ((*print-pretty* t)
	    (*print-length* nil)
	    (*print-level* nil))
	(dolist (base-class '( <<A LIST OF CLASSES>> ))
	  (format t "~2%;;; ~(~S~)~2%~S"
		  `(generate-prefill-dispatch-caches ',base-class)
		  (generate-prefill-dispatch-caches base-class))))))

(defun generate-prefill-dispatch-caches (class-name)
  (let ((generic-functions nil)
	(classes nil))
    (clos-internals::map-over-class-and-its-subclasses class-name
      #'(lambda (class)
	  (pushnew (class-name class) classes)
	  (clos-internals::map-over-dispatch-table
	    #'(lambda (selector handler extra-argument)
		(typecase selector
		  (cons
		    (pushnew (first selector) generic-functions))
		  (clos-internals::generic-function-selector
		    (when (clos-internals::generic-function-clos selector)
		      (pushnew (clos-internals::funcallable-instance-from-generic-selector
				 selector)
			       generic-functions)))
		  (otherwise))
		(values selector handler extra-argument))
	    (clos-internals::%instance-information-dispatch-table
	      (clos-internals::class-instance-information class)))))
    (setq generic-functions (sort generic-functions
				  #'(lambda (x y)
				      (setq x (clos:generic-function-name x)
					    y (clos:generic-function-name y))
				      (let ((xx (if (atom x) x (second x)))
					    (yy (if (atom y) y (second y))))
					(if (eq xx yy)
					    (or (atom x)
						(and (consp y)
						     (string<= (first x) (first y))))
					    (string<= xx yy))))))
    `(prefill-dispatch-caches
      ,@(mapcar
	 #'(lambda (generic-function)
	     (let ((nargs
		    (length (clos-internals::dispatching-funcallable-instance-precedence-order
			      generic-function)))
		   (calls nil))
	       (labels ((mapper (dispatch handler extra-argument state &rest arguments)
			  (declare (dynamic-extent arguments))
			  (ecase (clos-internals::dispatch-type dispatch)
			    (clos-internals::class-dispatch
			      (apply #'clos-internals::generic-function-map-over-dispatch
				     generic-function handler extra-argument state
				     #'mapper
				     (clos-internals::class-dispatch-position dispatch)
				     (class-name
				       (clos-internals::class-dispatch-class dispatch))
				     arguments))
			    (clos-internals::eql-dispatch
			      (let ((key-or-nil
				      (clos-internals::eql-dispatch-key-or-nil dispatch)))
				(when key-or-nil
				  (apply #'clos-internals::generic-function-map-over-dispatch
					 generic-function handler extra-argument state
					 #'mapper
					 (clos-internals::eql-dispatch-position dispatch)
					 `(eql ,(cond ((typep key-or-nil '(or number
									      character
									      (member t nil)
									      keyword))
						       key-or-nil)
						      (t `',key-or-nil)))
					 arguments))))
			      (clos-internals::finish-dispatch
				(when (do ((l arguments (cddr l)))
					  ((null l) nil)
					(when (member (second l) classes)
					  (return t)))
				  (pushnew (do ((i (1- nargs) (1- i))
						(l nil))
					       ((< i 0) l)
					     (push (getf arguments i 't) l))
					   calls :test #'equal))))
			    (values handler extra-argument)))
		   (clos-internals::map-over-generic-function-computed-dispatches
		     generic-function #'mapper)
		   `(,(clos:generic-function-name generic-function)
		     ,@calls))))
	   generic-functions))))

(defmacro prefill-dispatch-caches (&body clauses &environment env)
  (let (function)
    (labels ((expand-clause (clause)
	       (setq function (car clause))
	       (unless (clos-internals::fboundp-in-environment function env)
		 #+++ignore	;until we fix CLOS
		 (warn "prefill-dispatch-caches: ~S is not a defined generic function."
		       function))
	       (mapcan #'expand-call (cdr clause)))
	     (expand-call (args)
	       (dolist (arg args)
		 (unless (cond ((atom arg) (find-class arg nil env))
			       ((eq (first arg) 'eql) t)
			       ((eq (first arg) 'presentation-type)
				(find-presentation-type-class (second arg) nil env)))
		   #+++ignore	;until we fix CLOS
		   (warn "prefill-dispatch-caches: ~S is not a valid specializer in the ~
			  arguments to ~S."
			 arg function)))
	       `(',function
		 ,(if (some #'needs-evaluation args)
		      `(list ,@(mapcar #'(lambda (arg)
					   (if (and (consp arg) (eq (first arg) 'eql))
					       ``(eql ,,(second arg))
					       ``,',arg))
				       args))
		      `',(mapcar #'(lambda (arg)
				     (if (and (consp arg) (eq (first arg) 'eql))
					 `(eql ,(eval (second arg)))
					 arg))
				 args))))
	     (needs-evaluation (arg)
	       (and (consp arg)
		    (eq (first arg) 'eql)
		    (not (if (consp (second arg))
			     (eq (first (second arg)) 'quote)
			     (typep (second arg)
				    '(or number character keyword (member t nil))))))))
      `(prefill-dispatch-caches-1
	 ,@(mapcan #'expand-clause clauses)))))

(defun prefill-dispatch-caches-1 (&rest calls)
  (declare (dynamic-extent calls))
  (dorest (calls calls cddr)
    (let ((generic-function
	    (and (clos-internals::fboundp-in-environment (first calls) nil)
		 (clos-internals::fdefinition-in-environment (first calls) nil)))
	  (arguments (mapcar #'(lambda (arg)
				 (setq arg (cond ((atom arg) (find-class arg))
						 ((eq (first arg) 'eql) arg)
						 ((eq (first arg) 'presentation-type)
						  (find-presentation-type-class (second arg)))
						 (t
						  (error "Invalid argument specification: ~S"
							 arg))))
				 (when (typep arg 'class)
				   (unless (clos-internals::class-finalized-p arg)
				     (clos-internals::finalize-inheritance arg)))
				 arg)
			     (second calls))))
      (unless (typep generic-function 'generic-function)
	(error "~S is not a defined generic function." (first calls)))
      #+(or Genera Cloe-Runtime)
      (clos-internals::generic-function-ensure-specializers-mapped
	generic-function arguments #'clos-internals::standard-method-combiner)
      #-(or Genera Cloe-Runtime)
      (error "I don't know how to prefill generic function dispatch caches except in Symbolics CLOS"))))