1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
426
427
428
429
430
431
432
433
434
435
436
437
438
439
440
441
442
443
444
445
446
447
448
449
450
451
452
453
454
455
456
457
458
459
460
461
462
463
464
465
466
467
468
469
470
471
472
473
474
475
476
477
478
479
480
481
482
483
484
485
486
487
488
489
490
491
492
493
494
495
496
497
498
499
500
501
502
503
504
505
506
507
508
509
510
511
512
513
514
515
516
517
518
519
520
521
522
523
524
525
526
527
528
529
530
531
532
533
534
535
536
537
538
539
540
541
542
543
544
545
546
547
548
549
550
551
552
553
554
555
556
557
558
559
560
561
562
563
564
565
566
567
568
569
570
571
572
573
574
575
576
577
578
579
580
581
582
583
584
585
586
587
588
589
590
591
592
593
594
595
596
597
598
599
600
601
602
603
604
605
606
607
608
609
610
611
612
613
614
615
616
617
618
619
620
621
622
623
624
625
626
627
628
629
630
631
632
633
|
;;; -*- Mode: LISP; Syntax: Common-Lisp; Package: Memoization; Base: 10 -*-
(in-package "MEMOIZATION")
;;;===========================================================================
;;; (C) 1992 Marty Hall. Permission is granted for any use or modification
;; of this code provided this notice is retained. Version of 8/93.
;;;===========================================================================
;;;===========================================================================
;;; This file is one of four files that define the Memoization facility:
;;; - Load-Memoization: Defines Memoization package and loads other 3 files
;;; - Memoization [THIS FILE]: Defines core memoization routines.
;;; - Save-Memo-Table: Defines routines to save and load hash tables
;;; associated with a memoized function.
;;; - Memoization-Examples: Simplistic version of memoization to illustrate
;;; the principle, and 2 example functions to which
;;; memoization can be applied.
;;;
;;; This file [Memoization] is divided into the following major sections:
;;; - Section 1: A high level description of the main user routines
;;; - Section 2: A quick overview of the applications of memoization
;;; - Section 3: The source code for the main user routines
;;; - Section 4: The source code for lower-level internal routines
;;;
;;; Marty Hall
;;; The Johns Hopkins University Applied Physics Lab
;;; Room 7-38
;;; Johns Hopkins Rd.
;;; Laurel MD 20723
;;; hall@aplcenmp.apl.jhu.edu
;;; (410) 792-6000 x3440
;;;===========================================================================
;;;===========================================================================
;;; SECTION 1 - High Level Description
;;; ----------------------------------
;;; Memoization routines and utilities. The idea of memoization is that it
;;; allows a function to "remember" previous invocations, returning the
;;; previously calculated values (rather than recalculating) if it is called
;;; with exactly the same arguments as in a previous execution. This can
;;; result in tremendous speedups if calculations are repeated at various
;;; points in a program's execution, yet while remaining somewhat transparent
;;; to the users of the code.
;;;
;;; The main user routines:
;;; =======================
;;;
;;; DEFINE-MEMO-FUNCTION: a macro that can be used just like "defun", but
;;; which has the result of defining a memoized function. Also updates
;;; the doc string and the results of calling "Arglist" (if available in
;;; current LISP implementation) on that function name. Any of the keywords
;;; acceptable to Memoize can optionally be passed on, resulting in
;;; specialized versions of memoization that seed their initial hash
;;; tables from the disk, use particular hash table tests, etc.
;;; WITH-MEMOIZATION: a macro that takes a list of function names and any
;;; number of LISP forms and executes them in a context where the
;;; functions are temporarily memoized.
;;; (With-Memoization (Foo Bar Baz)
;;; (Form-1)
;;; (Form-2)) results in executing the two forms while functions
;;; named Foo, Bar, and Baz are memoized. Useful for getting a quick feel
;;; for the potential speed benefits of memoization.
;;; WITHOUT-MEMOIZATION: a macro that executes LISP forms in a context
;;; where all memoization is temporarily turned off.
;;; (Without-Memoization
;;; (Form-1)
;;; (Form-2)) executes the two forms with no functions memoized.
;;; MEMOIZE: Takes a function name and changes its function definition to
;;; be a memoized function.
;;; (defun Foo (Args) <Body of Foo>) followed by
;;; (Memoize 'Foo) has the same effect as doing
;;; (Define-Memo-Function Foo (Args) <Body of Foo>), but calling
;;; "Memoize directly is sometimes more convenient when testing things
;;; out, as it requires no changes in the preexisting code.
;;; SAVE-MEMO-TABLE: Saves to disk a definition of the hash table
;;; associated with a given memoized function name. By defining a
;;; memoized function via
;;; (Define-Memo-Function Foo (<Args>)
;;; <Body>)
;;; running the time-consuming cases off-line, calling
;;; (Save-Memo-Table '<Function-Name>)
;;; then using
;;; (Define-Memo-Function Foo (<Args>)
;;; (:Hash-Table-Source :Disk)
;;; <Body>)
;;; or by calling Memoize with the :Hash-Table-Source set to :Disk,
;;; you can have a function "remember" the values it calculated, not only
;;; in the current run but also in the previous off-line run.
;;; CLEAR-MEMO-TABLE: Takes a function name and clears out the memo table
;;; associated with the function. Useful when some internal change makes
;;; the previously stored values incorrect.
;;; UNMEMOIZE: Takes a function name and returns it to the unmemoized form.
;;; Useful for timing and for debugging, especially tracing recursive
;;; routines. In combination with "Memoize", this lets you switch back
;;; and forth between memoized and normal versions without changing or
;;; reloading the code. Similarly, Unmemoize-Functions takes a list
;;; instead of a single one, and Unmemoize-All-Functions unmemoizes
;;; everything.
;;; REMEMOIZE: Takes the name of a function that is currently unmemoized,
;;; but which had previously been memoized. Memoizes it again, but uses
;;; the previous hash table instead of creating a new one. Similarly,
;;; Rememoize-Functions applies to a list.
;;; MEMOIZED-FUNCTION-CALL-COUNT: Given the name of a memoized function,
;;; tells how many times that function has been called, and which of
;;; those were simple table lookups that had been stored from a previous
;;; invocation, vs how many were newly calculated using the original
;;; function. For a normal memoized function, lets the user see if
;;; memoization is paying off after a long period of time. For a function
;;; whose memo table was stored on disk, lets the user see if the stored
;;; values covered all or most of the cases.
;;; MEMOIZED-TIME: Takes a list of functions and a single form and evaluates
;;; and times the form 3 times, once without memoization, once with
;;; memoization and an empty cache, and once with memoization but the
;;; full cache from the previous run.
;;; *MEMOIZED-FUNCTION-NAMES*: a list of the currently memoized functions.
;;;
;;; "Memoize", "Memo", and "Clear-Memo-Table" were based on code in Peter
;;; Norvig's outstanding book _Paradigms of AI Programming: Case Studies in
;;; Common LISP_, Morgan Kaufmann, 1992, which in turn was inspired by code in
;;; ex. 3.27 of Abelson, Sussman, and Sussman's _Structure and Interpretation
;;; of Computer Languages_, MIT Press, 1985. Comments and suggestions on the
;;; code were given by Jim Mayfield (University of Maryland Baltimore County),
;;; J. Paul McNamee (AAI Corporation), Peter Norvig (Sun Microsystems), and
;;; David Scheerer (The Johns Hopkins Applied Physics Lab).
;;;===========================================================================
;;;===========================================================================
;;; SECTION 2 - Applications
;;; ------------------------
;;; There are four basic applications of memoization. The first, which is
;;; illustrated below, is when a single routine calls some subroutine (or
;;; itself recursively) more than is needed, resulting in extra calculations.
;;; By memoizing, these results are returned immediately for subsequent calls,
;;; with the effect of dynamic programming. In fact, this first case can be
;;; thought of as a tool for automatic dynamic programming, but without the
;;; need to build the subpieces in the correct order. This can frequently
;;; reduce the time of exponential algorithms to polynomial or even linear
;;; time. Given enough thought, this can be solved without an automatic
;;; memoization facility by either building up the subpieces in the proper
;;; order or maintaining a special purpose local data structure to retain the
;;; results (ie "manual" memoization). The advantage of doing it automatically
;;; is that less debugging and testing is required if the simple algorithm has
;;; been already tested, the versions can be changed back and forth
;;; interactively at run time, it is more transparent, and most importantly it
;;; is simple and easy to use.
;;;
;;; The second case is for invocations of a function that are repeated over
;;; time, but from scattered places in the program, or even when revoked
;;; repeatedly by a user in an interactive program. This generally yields a
;;; speedup by a constant factor, but that factor may be large. Without an
;;; automatic memoization facility, the only alternative is maintaining a
;;; special purpose global data structure, requiring testing and debugging,
;;; and much extra effort for something that at best is equally efficient as
;;; memoization.
;;;
;;; The third case is when a function is so expensive that you want to
;;; perform the calculations off-line and save the results for a later
;;; session. The automatic memoization facility provides a simple and
;;; transparent method to save the results and have them associated with the
;;; function automatically in a later session.
;;;
;;; The final case is when using memoization as a tool in conventional
;;; performance profiling and optimization. Many implementations provide some
;;; sort of a metering system, and this should be used for major test cases.
;;; However, there is often tremendous overhead involved, with 20-30x slower
;;; performance when a routine is fully metered. For quick test cases, it is
;;; often useful to know if speeding up a particular routine will have much
;;; effect on the top-level timing. By using Memoized-Time or
;;; With-Memoization, a user can memoize the routines in question then run the
;;; same test case multiple times. If the identical test case runs only, say
;;; 5% faster even during the second memoized run, then this suggests that no
;;; amount of memoization in the routines in question will make more than a 5%
;;; difference in the performance of the test case, and that this is likely
;;; not the place to begin the optimization efforts.
;;;===========================================================================
;;;===========================================================================
;;; SECTION 3 - The main user routines
;;; ----------------------------------
;;; A quick summary of these is provided at the top in section 1.
;;;===========================================================================
;;;===========================================================================
;;; This records the name of every function that is memoized.
(defvar *Memoized-Function-Names* '() )
;;;===========================================================================
;;; Defines a macro that you use like "defun" but that automatically memoizes
;;; the resultant function. REMEMBER! This is a macro, and thus changes here
;;; do not get propagated to files that use this until they are recompiled. So,
;;; if you want to change this in an incompatible manner, check
;;; *Memoized-Function-Names* first, then be sure to recompile all the files
;;; that use those functions afterwards.
;;;
;;; After Function-Name and Arguments but before the function body, a list
;;; of keywords and values for Memoize may be specified, as shown in the example
;;; in the doc string below. See "Memoize" for a list of legal keywords and an
;;; explanation of their values.
(defmacro Define-Memo-Function (Function-Name Arguments &body Keys-and-Fn-Body)
"Same syntax as `defun', but defines a memoized function. After the function
args, but before the function body, you can optionally supply a list of
keywords to Memoize. Eg
(Define-Memo-Function Square (X) (* X X)) OR
(Define-Memo-Function Square (X)
(:Hash-Table-Source :Create :Test #'eq) <-- Any keys `Memoize' accepts
(* X X))"
(let ((Keys '())
(First-Entry (first Keys-and-Fn-Body)))
(when (and (listp First-Entry)
(keywordp (first First-Entry)))
(setq Keys First-Entry)
(setq Keys-and-Fn-Body (rest Keys-and-Fn-Body)))
`(progn
(Unmemoize ',Function-Name)
(apply #'Memoize
(defun ,Function-Name ,Arguments ,@Keys-and-Fn-Body)
',Keys)) ))
;;;===========================================================================
;;; This and Define-Memo-Function (which expands into Memoize) are the main two
;;; functions user's would use to create their own memoized functions. Any
;;; keywords acceptable to Memoize can be passed to Define-Memo-Function as a
;;; list specified after the function-name and function-lambda-list, but before
;;; the function-body. See Define-Memo-Function for an example.
;;;
;;; Takes a function name, looks up the associated function object, and replaces
;;; it with a function object that "remembers" previous values. See "Memo" for
;;; more on how this is done. In addition, it updates the documentation string
;;; of the function to reflect that it is memoized, and sets up some
;;; bookkeeping that will be used to keep track of the number of times the
;;; new, memoized function gets called, broken down by whether or not it
;;; returned a cached value.
;;;
;;; "Test" must be a predicate acceptable to make-hash-table. Generally #'eq or
;;; #'equal.
;;;
;;; "Key" is used if memoization is to be performed based on some transformation
;;; (eg a subset) of the argument list.
;;;
;;; "Hash-Table-Source" is one of
;;; :Create -- make a new hash table
;;; :Disk -- load a table from disk that was previously saved via
;;; Save-Memo-Table.
;;; :Old-Function -- Use the previous hash table. This assumes this function
;;; used to be memoized, was unmemoized, and now is being
;;; memoized again (with the old table still on the function
;;; names :Memo-Table property).
;;;
;;; "One-Arg-p" is a flag indicating whether or not to use the restricted but
;;; slightly faster version that assumes a single argument to the function
;;; that can be compared via "eq".
(defun Memoize (Function-Name &key (Test #'equal)
(Key #'identity)
(Hash-Table-Source :Create)
One-Arg-p)
"Alters function to save previously calculated values in a hash table"
(cond
((Memoized-Function-p Function-Name)
(format t "~%~S is already memoized." Function-Name))
(t
(let ((Doc-String (documentation Function-Name 'function)))
(push Function-Name *Memoized-Function-Names*)
(if
One-Arg-p
(setf (symbol-function Function-Name)
(One-Arg-Memo (symbol-function Function-Name)
:Function-Name Function-Name))
(setf (symbol-function Function-Name)
(Memo (symbol-function Function-Name)
:Function-Name Function-Name
:Test Test
:Key Key
:Hash-Table-Source Hash-Table-Source)))
(setf (get Function-Name :Unmemoized-Doc-String) Doc-String)
(setf (documentation Function-Name 'function)
(Memoized-Doc-String Function-Name Doc-String))
(setf (get Function-Name :Hash-Table-Lookups) 0)
(setf (get Function-Name :Original-Function-Calls) 0))))
Function-Name
)
;;;===========================================================================
;;; Assumes default values for test, key, Hash-Table-Source, and One-Arg-p.
;;; "dolist" instead of "loop" to maintain CLtL/1 compatibility.
(defun Memoize-Functions (Function-Names &key (Test #'equal)
(Key #'identity)
(Hash-Table-Source :Create)
One-Arg-p)
(dolist (Function-Name Function-Names Function-Names)
(Memoize Function-Name
:Test Test
:Key Key
:Hash-Table-Source Hash-Table-Source
:One-Arg-p One-Arg-p)) )
;;;===========================================================================
;;; The unwind-protect is in case the user aborts during the body, so that
;;; things don't get left unmemoized. It is common for the user to abort
;;; during the body, since the unmemoized version might be much slower than
;;; they expected.
(defmacro Without-Memoization (&body Forms)
"Executes forms with all memoization temporarily turned off"
(let ((Arg (gensym "MEMOIZED-FUNCTIONS-")))
`(let ((,Arg *Memoized-Function-Names*))
(unwind-protect
(progn
(Unmemoize-All-Functions)
,@Forms)
(Rememoize-Functions ,Arg))) ))
;;;===========================================================================
;;; Executes Forms in a context where the listed function names are
;;; temporarily memoized.
(defmacro With-Memoization ((&rest Function-Names) &body Forms)
"Executes forms with the listed functions temporarily memoized"
(let ((Arg (gensym "TEMPORARILY-MEMOIZED-FUNCTIONS-")))
`(let ((,Arg ',Function-Names))
(Memoize-Functions ,Arg)
(unwind-protect
(progn ,@Forms)
(Unmemoize-Functions ,Arg))) ))
;;;===========================================================================
;;; Times the Form 3 times: without any new memoization, with memoization and
;;; an initially empty hash table, and with memoization but with the memo
;;; tables left in their full state from the previous run.
(defmacro Memoized-Time ((&rest Function-Names) Form)
"Times form 3 times: without new memoization, with memoization and an
initially empty table, and then again without clearing the table"
`(progn
(format t "~%---------------------------------------------")
(format t "~%Without additional memoization:")
(time ,Form)
(With-Memoization ,Function-Names
(format t "~%---------------------------------------------")
(format t "~%First memoized invocation:")
(time ,Form)
(format t "~%---------------------------------------------")
(format t "~%Second memoized invocation:")
(time ,Form))
(format t "~%---------------------------------------------"))
)
;;;===========================================================================
;;; Given the name of a memoized function, tells how many times that function
;;; has been called, and which of those were simple table lookups that had
;;; been stored from a previous invocation, vs how many were newly calculated
;;; using the original function. For a normal memoized function, lets the user
;;; see if memoization is paying off after a long period of time. For a
;;; function whose memo table was stored on disk, lets the user see if the
;;; stored values covered all or most of the cases.
(defun Memoized-Function-Call-Count (Function-Name &key (Print-p t))
"List of table lookups and calls to original function for a memoized function"
(cond
((not (Memoized-Function-p Function-Name))
(format t "~%~S is not memoized!" Function-Name))
((One-Arg-Memoized-Function-p Function-Name)
(format t "~%~S was memoized with the restricted case that assumes ~%~
only 1 argument and does not keep track of function calls."
Function-Name))
(t
(let* ((Table-Lookups (get Function-Name :Hash-Table-Lookups))
(Function-Calls (get Function-Name :Original-Function-Calls))
(Total (+ Table-Lookups Function-Calls))
(Table-Lookup-Percentage (if (> Total 0)
(round (* 100 (/ Table-Lookups Total)))
NIL)))
(when Print-p
(if Table-Lookup-Percentage
(format t "~%Function ~S was invoked ~S times. ~%~
~S% were memo table lookups, and ~S% ~
were calls to the original function."
Function-Name
Total
Table-Lookup-Percentage
(- 100 Table-Lookup-Percentage))
(format t "~%Function ~S was never invoked." Function-Name)))
(list Table-Lookups Function-Calls))) ))
;;;===========================================================================
;;; This is needed if you want to clear out the old values, but leave the
;;; function memoized for the future. This is often done if one of the
;;; subfunctions that Function-Name calls changes, so that the previously
;;; stored values are no longer accurate.
(defun Clear-Memo-Table (Function-Name)
"Removes all entries from hash table associated with memoized function"
(let ((Hash-Table (get Function-Name :Memo-Table)))
(when Hash-Table
(clrhash Hash-Table))))
;;;===========================================================================
;;; Takes a list of names instead of just one.
(defun Clear-Memo-Tables (Function-Name-List)
"Clears the cache for a list of functions via calls to Clear-Memo-Table"
(mapc #'Clear-Memo-Table Function-Name-List))
;;;===========================================================================
;;; Unmemoizes - changes the function definition back to the original one, and
;;; resets the doc string. Useful for timing and for debugging, especially
;;; with recursive code. The function returns t if the function was already
;;; memoized (and thus unmemoized), NIL if it was not already memoized (in
;;; which case no action was taken).
(defun Unmemoize (Function-Name)
"Returns function to original, unmemoized form. Returns NIL if not memoized"
(let ((Original-Function (get Function-Name :Unmemoized-Function)))
(when
Original-Function
(setq *Memoized-Function-Names*
(remove Function-Name *Memoized-Function-Names*))
(setf (symbol-function Function-Name) Original-Function)
(setf (documentation Function-Name 'function)
(get Function-Name :Unmemoized-Doc-String))
(setf (get Function-Name :Unmemoized-Function) NIL)
t) ))
;;;===========================================================================
;;; Takes a list of names instead of just one.
(defun Unmemoize-Functions (Function-Name-List)
"Unmemoizes a list of functions via successive calls to Unmemoize"
(mapc #'Unmemoize Function-Name-List) )
;;;===========================================================================
;;; Unmemoizes all functions that are currently memoized, returning a list of
;;; their names. This is useful when doing time comparisons and optimizations
;;; and you want all memoization turned off. The list of names can be saved
;;; for later re-memoization.
(defun Unmemoize-All-Functions ()
"Unmemoizes all currently-memoized functions"
(let ((Previously-Memoized-Functions *Memoized-Function-Names*))
(Unmemoize-Functions *Memoized-Function-Names*)
Previously-Memoized-Functions))
;;;===========================================================================
;;; Takes a function that had previously been memoized, but is now unmemoized.
;;; Memoizes it again, keeping the original hash table instead of creating a
;;; new one. Note that there is no :Hash-Table-Test or :Key options as in
;;; Memoize, since they only make sense if a new hash table were being created.
(defun Rememoize (Function-Name)
(Memoize Function-Name :Hash-Table-Source :Old-Function))
;;;===========================================================================
;;; Takes a list of names instead of just one.
(defun Rememoize-Functions (Function-Name-List)
(mapc #'Rememoize Function-Name-List))
;;;===========================================================================
;;;===========================================================================
;;; SECTION 3 - Internal Routines
;;; -----------------------------
;;;===========================================================================
;;;===========================================================================
;;; This function is not normally called directly but is accessed via "Memoize".
;;;
;;; Memo: takes a function object as an argument, and returns a new function
;;; object which can "remember" previously calculated values. Basically, if
;;; the arguments have been seen before, they are used as key into the hash
;;; table, and that stored value is returned. If not, the original function is
;;; called, the results are stored in the hash table with the argument list as
;;; the key, and then those results are returned. This yields function
;;; behavior that, in many cases, is virtually transparent to the user, except
;;; for the potentially large performance gains.
;;;
;;; In addition, it takes four keywords args: Function-Name, Test, Key, and
;;; Hash-Table-Source The function name is needed so that its property list
;;; can be used to record the associated hash table (to clear or save if
;;; requested) and the original function definition (to allow reversing the
;;; memoization later). Specifying a Test of "eql" and a Key of "first" is
;;; useful if the function takes only a single argument which is amenable to
;;; eql testing, or if you want to only treat parts of the argument list as
;;; significant with respect to determining which values to return. The
;;; Restore-Old-Table? flag, if non-NIL, starts the memo-table "primed" with
;;; values calculated in a previous run and saved via "Save-Memo-Table".
;;;
;;; The copy-list business is needed on LISP machines because cdr-coding
;;; prevents direct comparisons of &rest arguments. In my experience,
;;; hashing on Symbolics is enough faster that the whole process about the
;;; same relative speed vs Unix Lisps.
;;;
;;; Hash-Table-Source is one of
;;; :Create -- make a new hash table
;;; :Disk -- load a table from disk that was previously saved via
;;; Save-Memo-Table.
;;; :Old-Function -- Use previous one, which assumes this function used to be
;;; memoized, then unmemoized, + now is being memoized again
;;;
(defun Memo (Function &key Function-Name
(Test #'equal)
(Key #'identity)
(Hash-Table-Source :Create))
"Takes a normal function object and returns an `equivalent' memoized one"
(let ((Hash-Table (ecase Hash-Table-Source
(:Create (make-hash-table :test Test))
(:Disk (Load-Saved-Memo-Table Function-Name))
(:Old-Function (get Function-Name :Memo-Table)))))
(setf (get Function-Name :Memo-Table) Hash-Table)
(setf (get Function-Name :Unmemoized-Function) Function)
(setf (get Function-Name :Memo-Table-Test) Test)
#'(lambda (&rest Args)
(declare (optimize (speed 3) (safety 1)))
(let ((Hash-Key (funcall Key #+:LispM(copy-list Args)
#-:LispM Args )))
(multiple-value-bind (Value Found?)
(gethash Hash-Key Hash-Table)
(cond
(Found?
(incf (the fixnum (get Function-Name :Hash-Table-Lookups)))
Value)
(t
(incf (the fixnum (get Function-Name :Original-Function-Calls)))
(setf (gethash Hash-Key Hash-Table)
(apply Function Args))))))) ))
;;;===========================================================================
;;; Similar to the above, but has only a single argument testable by eq, and
;;; does not keep track of function call counts. For a function of one
;;; eq-testable-argument, this is about 2.5 times faster than the more general
;;; Memo, even if :test #'eq and :key #'first are specified. On most machines
;;; this difference is down in the thousandths of a second range, but is still
;;; useful in the cases of low-overhead functions that are called many times.
(defun One-Arg-Memo (Function &key Function-Name)
"Takes a normal function object and returns an `equivalent' memoized one"
(let ((Hash-Table (make-hash-table)))
(setf (get Function-Name :Memo-Table) Hash-Table)
(setf (get Function-Name :Unmemoized-Function) Function)
#'(lambda (Arg)
(multiple-value-bind (Value Found?)
(gethash Arg Hash-Table)
(if
Found?
Value
(setf (gethash Arg Hash-Table) (funcall Function Arg))))) ))
;;;===========================================================================
;;; Tests if the symbol refers to a function that is memoized. This property
;;; is removed when the function is unmemoized.
(defun Memoized-Function-p (Function-Name)
"Predicate to test if function is memoized"
(get Function-Name :Unmemoized-Function) )
;;;===========================================================================
;;; Tests if the symbol refers to a function that was memoized with the
;;; :one-arg-p flag set, which results in restricted memoization for arguments
;;; of one parameter that are testable by eq.
(defun One-Arg-Memoized-Function-p (Function-Name)
"Predicate to test if function is memoized by restricted 1-argument version"
(and (Memoized-Function-p Function-Name)
(not (get Function-Name :Memo-Table-Test))) )
;;;===========================================================================
;;; Converts the original, unmemoized doc string into a new one appropriate
;;; for the memoized function.
(defun Memoized-Doc-String (Function-Name Original-Doc-String)
"Returns a new doc string to be used with the memoized function"
(format nil
"~S is a memoized function, returning previously calculated~%~
values from a hash table instead of recalculating them.~%~A"
Function-Name
(Original-Doc-String-Description Original-Doc-String))
)
;;;===========================================================================
;;; Returns a short string describing previous documentation string.
(defun Original-Doc-String-Description (String-or-NIL)
"Returns a string based on a function's original documentation"
(if
String-or-NIL
(format nil "The original documentation was~%`~A'." String-or-NIL)
(format nil "Original function had no documentation.")))
;;;===========================================================================
;;; Returns a new definition of "arglist". The "arglist" function is not part
;;; of Common LISP, but is contained in many of the implementations, including
;;; at least Symbolics, Lucid, Franz (Allegro), and Apple (MCL). This function
;;; returns a list giving the argument list to the function, as written by the
;;; user. Since memoization causes a function's arglist to become "&rest
;;; Args", this simply gives a more useful description, mostly by showing what
;;; the arglist of the original (i.e. unmemoized) function was. Change the
;;; definition of Arglist-Function-Name if it is different in your
;;; implementation.
(defun Redefine-Arglist ()
"Alters `arglist' to show original arguments for memoized functions"
(let ((Arglist-Function-Name 'common-lisp-user::arglist))
(when
(and (fboundp Arglist-Function-Name)
(not (get Arglist-Function-Name :Original-Definition)))
(setf (symbol-function Arglist-Function-Name)
(let ((Original-Definition
(symbol-function Arglist-Function-Name)))
(setf (get Arglist-Function-Name :Original-Definition)
Original-Definition)
#'(lambda (Function-Name &rest Unused-Args)
(declare (ignore Unused-Args))
(let ((Unmemoized-Function
(if (symbolp Function-Name)
(get Function-Name :Unmemoized-Function))))
(if
Unmemoized-Function
`(&rest Memoized-Args
(originally ,(funcall Original-Definition
Unmemoized-Function)))
(funcall Original-Definition Function-Name)))) )))))
(eval-when (eval load) (Redefine-Arglist))
;;;===========================================================================
|
