[Date Prev][Date Next][Thread Prev][Thread Next][Date Index][Thread Index]
compile-flavor-methods for CLOS
Date: Tue, 18 Dec 1990 16:33-0500
From: SWM@sapsucker.scrc.symbolics.com (Scott McKay)
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.
CLOS is extremely painful to use when one has to wait around for method
combination. So, providing some pointers for how to roll your own is most
helpful, especially when nobody is paying you to do it. The real problem is
the absence of a compile-flavor-methods analog in the design spec for CLOS.
The absence of this functionality can render CLOS unusable for important
applications: The reason someone writes code in lisp is often to get an
application running quickly to show proof of concept. How does this logic
hold up if, when the time for their demo comes, their application runs
incredibly slowly for the five minutes that the sponsor is looking at it. It
is hard to believe that even though Symbolics CLOS supports locatives, it
doesn't support compile-methods. Compile-methods should definitely be in 8.1.
[... flame on ...
Warning managers: the following may be hazardous to your job.]
Symbolics purports to sell software support. If it expects anybody to buy it,
it should provide some support. Well, here is an obvious opportunity to
provide some simple and useful support instead of milking the support business
to fund the latest (last?) boondoggle misconceived by its top non-manager to
cover the preceding series of management disasters.
How do you take some of the best talent in the computer industry (which
Symbolics had as of 1986) and lose miserably? Answer: incompetent management.
How do you cover it up? Answer: Blame it on the technology (LISP) and the
talent, studiously ignoring blunders in public relations, marketing, sales,
organization, finance, and strategic orientation -- the basic elements of
business. (Look at Sun. What did it have? Answer: talented management)
Indeed, the biggest reason for not buying Lisp Machines is Symbolics'
reputation for managerial incompetence. This is what costs Symbolics most in
sales, not the lisp technology which remains vastly superior to *all*
alternatives. Needless to say, it is rather difficult to get management to
admit this, let alone fix itself.
Informed observers find it particularly disheartening to see incompetent
management squander a national resource. At least, we can take heart in the
prospect that sometime after the mid-1990s low-cost, mass prodcued PCs will
reinvent many of the good ideas from the Lisp Machine environment of the
1980s, especially the visible items such as object-oriented programming,
graphics, and 3D modeling. But, what about the advanced programming
environment of the 1990s or the twenty-first century?
[... flame off ...]
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,
This is bogus. Am I going to run my application before a I save out my world
load? Running this code is merely going to call some functions that
instantiate structure which #3 is going to rely on. The question is what are
the functions that running the code calls. This should then be combined with
#3 to provide some kind of compile methods equivalent for specific methods,
perhaps using a syntax like, (compile-methods generic-function (arg1.
arg1-classes) (arg2 . arg2-classes) ...).
(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"))))