/[meta-cvs]/meta-cvs/F-C31E700EDDDAF96042E6C4EBC25830C3.lisp
ViewVC logotype

Contents of /meta-cvs/F-C31E700EDDDAF96042E6C4EBC25830C3.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.5 - (show annotations)
Wed Feb 12 07:02:13 2003 UTC (11 years, 2 months ago) by kaz
Branch: MAIN
CVS Tags: mcvs-1-0-3
Changes since 1.4: +58 -3 lines
Merging from mcvs-1-0-branch.

* code/memoize.lisp (remove-key-aux-rest, strip-lambda-list,
extract-tests, remove-tests, memoize-expander, factor-memo-labels,
define-memoized-function, memoized-labels): Documentation strings
added to this cryptic code.
1 ;;; This source file is part of the Meta-CVS program,
2 ;;; which is distributed under the GNU license.
3 ;;; Copyright 2002 Kaz Kylheku
4
5 (require "multi-hash")
6 (require "mcvs-package")
7 (provide "memoize")
8
9 (in-package "META-CVS")
10
11 (eval-when (:compile-toplevel :load-toplevel :execute)
12 (defun remove-key-aux-rest (lambda-list)
13 "Remove any trailing portion of the lambda list that starts with
14 one of the lambda list keywords &rest, &key, &aux or &body."
15 (cond
16 ((null lambda-list) nil)
17 ((member (first lambda-list) '(&rest &aux &key &body)) nil)
18 (t (cons (first lambda-list) (remove-key-aux-rest (rest lambda-list))))))
19
20 (defun strip-lambda-list (list)
21 "Simplify a lambda list by removing occurences of &optional, stripping
22 away the trailing portion using REMOVE-KEY-AUX-REST, canonicalizing
23 simple variable forms to lists so that SYMBOL becomes (SYMBOL), and removing
24 initializers so that (SYMBOL INITFORM) becomes (SYMBOL). This stripped
25 lambda list becomes the lambda list of the hidden inner function that
26 implements the guts of a memoized function, and captures the recursive
27 calls. The &OPTIONAL parameters are reduced to required ones, and there
28 are no trailing &KEY or &rest parameters."
29 (labels ((simplify-var-form (form)
30 (cond
31 ((eq '&optional form) nil)
32 ((symbolp form) (list form))
33 ((consp form) (list (first form)))
34 (t (error "MEMOIZE-EXPANDER: bad thing in lambda list: ~a~%"
35 form)))))
36 (mapcan #'simplify-var-form (remove-key-aux-rest list))))
37
38 (defun extract-tests (lambda-list)
39 "The memoize module understands special lambda lists which, as an extension
40 to regular Lisp lambda lists, allow the programmer to specify what test
41 function should be used for the hash table used to memoize over a given
42 parameter. This function parses such a lambda list and extracts the tests.
43 The subtlety here is that after the &optional keyword, the syntax changes.
44 For required parameters, the syntax which specifies the test is
45 (SYMBOL :TEST FUNCTION). For &optional paramters, the syntax becomes
46 (SYMBOL INITFORM :TEST FUNCTION). For any variable which doesn't specify
47 a test, the test is assumed to be #'eql."
48 (let ((saw-optional))
49 (mapcan #'(lambda (element)
50 (cond
51 ((eq '&optional element)
52 (setf saw-optional t)
53 nil)
54 ((consp element)
55 (if saw-optional
56 (destructuring-bind (var &optional init &key test) element
57 (declare (ignore var init))
58 (list (or test '#'eql)))
59 (destructuring-bind (var &key test) element
60 (declare (ignore var init))
61 (list (or test '#'eql)))))
62 (t (list '#'eql))))
63 (remove-key-aux-rest lambda-list))))
64
65 (defun remove-tests (lambda-list)
66 "This function removes the :test specifications from a the memoized
67 function lambda list, thereby reducing it to a regular lambda list.
68 See the docstring for EXTRACT-TESTS for a little more information.
69 We need to do this to generate the outer shell of the memoized function,
70 which is a normal Lisp function."
71 (let (saw-optional saw-key)
72 (mapcar #'(lambda (element)
73 (cond
74 ((eq '&optional element)
75 (setf saw-optional t)
76 element)
77 ((eq '&key element)
78 (setf saw-key t)
79 element)
80 ((consp element)
81 (if saw-key
82 element
83 (if saw-optional
84 (destructuring-bind (var &optional init &key test) element
85 (declare (ignore test))
86 (append (list var) (if init (list init))))
87 (destructuring-bind (var &key test) element
88 (declare (ignore test))
89 var))))
90 (t element)))
91 lambda-list)))
92
93 (defun memoize-expander (name lambda-list tests body expr)
94 "Produce a memoized function in the form of a LABELS function that is
95 wrapped in a LET block. The LET block sets up the hash table, either
96 a regular hash table if there is one paramter, or a MULTI-HASH if
97 there are several parameters. The body of the LABELS performs the
98 memoization stuff with the hash tables. Note that the function
99 FACTOR-MEMO-LABELS depends on this structure of the LABELS nested
100 within the LET."
101 (let ((multi-hash-sym (gensym "MULTI-HASH-"))
102 (hash-result-sym (gensym "HASH-RESULT-"))
103 (hash-found-sym (gensym "HASH-FOUND-"))
104 (dimensions (length lambda-list)))
105 `(let ((,multi-hash-sym ,(if (> dimensions 1)
106 `(make-instance 'multi-hash
107 :dimensions ,dimensions
108 :tests ,tests)
109 `(make-hash-table :test ,(second tests)))))
110 (labels ((,name ,lambda-list
111 (multiple-value-bind (,hash-result-sym ,hash-found-sym)
112 ,(if (> dimensions 1)
113 `(get-multi-hash ,multi-hash-sym
114 ,@lambda-list)
115 `(gethash ,@lambda-list
116 ,multi-hash-sym))
117 (if ,hash-found-sym
118 ,hash-result-sym
119 (setf ,(if (> dimensions 1)
120 `(get-multi-hash ,multi-hash-sym ,@lambda-list)
121 `(gethash ,@lambda-list ,multi-hash-sym))
122 (progn ,@body)))))) ,expr))))
123
124 (defun factor-memo-labels (memo-labels forms)
125 "This function takes a list of the LET expressions, each of which is assumed to
126 be generated by MEMOIZE-EXPANDER, and factors them out to produce one giant
127 LET block with all of the LET material (hash tables) coalesced together,
128 enclosing one big coalesced LABELS block that defines all of the functions
129 together. This trick allows us to generate individual memoized inner functions
130 using MEMOIZE-EXPANDER, and then fuse them together to make one big
131 party of mutually recursive memoized functions."
132 (macrolet ((destructure-memo-labels (labels &body labels-forms)
133 `(destructuring-bind (name outer-lambda
134 (let inner-lambda &rest labels-forms))
135 ,labels
136 (declare (ignorable name outer-lambda let inner-lambda
137 labels-forms))
138 ,@labels-forms)))
139 (flet ((extract-lets (labels)
140 (destructure-memo-labels labels
141 inner-lambda))
142 (extract-funcs (labels)
143 (destructure-memo-labels labels
144 `(,name ,outer-lambda ,@labels-forms))))
145 `(let ,(mapcan #'extract-lets memo-labels)
146 (labels ,(mapcar #'extract-funcs memo-labels) ,@forms))))))
147
148 (defmacro define-memoized-function (name lambda-list &body forms)
149 "Generate a DEFUN definition for a function called NAME, placing the
150 body into an inner recursive function of the same name that is memoized.
151 Effectively, this creates a memoized function: one whose recursive calls
152 are automatically cached using the parameter lists as keys into a multi-level
153 hash table. This is an important optimization technique when the recursion
154 contains overlapping cases; it can reduce exponential time to polynomial time.
155 This macro understands a special lambda list syntax. A required parameter
156 normally written as SYMBOL can be written (SYMBOL :TEST FUNC) to specify a
157 hashing equality function FUNC for that parameter which can be #'EQ,
158 #'EQL, #'EQUAL or #'EQUALP. For an optional parameter, this syntax is
159 (SYMBOL INIT-FORM :TEST FUNC). Note that only the outer function accepts
160 &KEY and &REST parameters, if any are specified. The inner recursive memoized
161 function does not; it has a simplified lambda list."
162 (let ((stripped-ll (strip-lambda-list lambda-list)))
163 `(defun ,name ,(remove-tests lambda-list)
164 ,(memoize-expander name stripped-ll `(list ,@(extract-tests lambda-list))
165 forms `(,name ,@stripped-ll)))))
166
167 (defmacro memoized-labels ((&rest memoized-labels-list) &body forms)
168 "Generate a block of mutually recursive LABELS functions, making the
169 DEFINE-MEMOIZED-FUNCTION utility available for local functions. See
170 the documentation string for that macro for more details."
171 (flet ((generate-labels-element (labels)
172 (destructuring-bind (name lambda-list &body labels-forms) labels
173 (let ((stripped-ll (strip-lambda-list lambda-list)))
174 `(,name ,(remove-tests lambda-list)
175 ,(memoize-expander name stripped-ll
176 `(list ,@(extract-tests lambda-list))
177 labels-forms
178 `(,name ,@stripped-ll)))))))
179 (factor-memo-labels (mapcar #'generate-labels-element
180 memoized-labels-list) forms)))

  ViewVC Help
Powered by ViewVC 1.1.5