ViewVC logotype

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

Parent Directory Parent Directory | Revision Log Revision Log

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

  ViewVC Help
Powered by ViewVC 1.1.5