From: Chris Hanson Date: Fri, 6 Jan 2017 21:29:57 +0000 (-0800) Subject: Implement memoizers. X-Git-Tag: mit-scheme-pucked-9.2.12~227^2~200 X-Git-Url: https://birchwood-abbey.net/git?a=commitdiff_plain;h=bcacbf8175526af7d39b3361b03e50dd389639f2;p=mit-scheme.git Implement memoizers. --- diff --git a/src/runtime/make.scm b/src/runtime/make.scm index abb6b1dbc..e0adb4088 100644 --- a/src/runtime/make.scm +++ b/src/runtime/make.scm @@ -449,6 +449,7 @@ USA. (RUNTIME STREAM) (RUNTIME 2D-PROPERTY) (RUNTIME HASH-TABLE) + (RUNTIME MEMOIZER) (RUNTIME PREDICATE-METADATA) (RUNTIME PREDICATE-LATTICE) (RUNTIME TAGGING) diff --git a/src/runtime/memoizer.scm b/src/runtime/memoizer.scm new file mode 100644 index 000000000..0df1e6e2b --- /dev/null +++ b/src/runtime/memoizer.scm @@ -0,0 +1,127 @@ +#| -*-Scheme-*- + +Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994, + 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005, + 2006, 2007, 2008, 2009, 2010, 2011, 2012, 2013, 2014, 2015, 2016, + 2017 Massachusetts Institute of Technology + +This file is part of MIT/GNU Scheme. + +MIT/GNU Scheme is free software; you can redistribute it and/or modify +it under the terms of the GNU General Public License as published by +the Free Software Foundation; either version 2 of the License, or (at +your option) any later version. + +MIT/GNU Scheme is distributed in the hope that it will be useful, but +WITHOUT ANY WARRANTY; without even the implied warranty of +MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +General Public License for more details. + +You should have received a copy of the GNU General Public License +along with MIT/GNU Scheme; if not, write to the Free Software +Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301, +USA. + +|# + +;;;; Memoizers +;;; package: (runtime memoizer) + +(declare (usual-integrations)) + +(define-record-type + (%make-memoizer-metadata table procedure) + memoizer-metadata? + (table %memoizer-metadata-table) + (procedure %memoizer-metadata-procedure)) + +(define (memoizer? object) + (and (apply-hook? object) + (memoizer-metadata? (apply-hook-extra object)))) + +(define (make-memoizer table procedure impl) + (guarantee hash-table? table 'make-memoizer) + (guarantee procedure? procedure 'make-memoizer) + (guarantee procedure? impl 'make-memoizer) + (make-apply-hook impl (%make-memoizer-metadata table procedure))) + +(define (memoizer-table memoizer) + (guarantee memoizer? memoizer 'memoizer-table) + (%memoizer-metadata-table (apply-hook-extra memoizer))) + +(define (memoizer-procedure memoizer) + (guarantee memoizer? memoizer 'memoizer-procedure) + (%memoizer-metadata-procedure (apply-hook-extra memoizer))) + +(define (clear-memoizer! memoizer) + (hash-table/clear! (memoizer-table memoizer))) + +(define (weak-eqv-memoizer get-key get-datum) + (let ((table (make-key-weak-eqv-hash-table))) + (make-memoizer table + get-datum + (lambda args + (hash-table/intern! table + (apply get-key args) + (lambda () (apply get-datum args))))))) + +(define (all-args-memoizer elt= get-key get-datum) + (let ((memoizer + (list-memoizer elt= + (lambda (args) + (apply get-key args)) + (lambda (args) + (apply get-datum args))))) + (make-memoizer (memoizer-table memoizer) + get-datum + (lambda args (memoizer args))))) + +(define (make-list-memoizer make-list= dedup?) + (lambda (elt= get-key get-datum) + (let ((list= (make-list= elt=))) + (let ((table (make-hash-table list= (equality-predicate-hasher list=)))) + (make-memoizer + table + get-datum + (lambda (list) + (let ((list + (if dedup? + (delete-duplicates list elt=) + list))) + (hash-table/intern! table + (get-key list) + (lambda () (get-datum list)))))))))) + +(define (make-list= elt=) + (let ((compare + (lambda (a b) + (list= elt= a b)))) + (set-equality-predicate-hasher! compare (%make-list-hash elt=)) + compare)) + +(define (make-lset= elt=) + (let ((compare + (lambda (a b) + (lset= elt= a b)))) + (set-equality-predicate-hasher! compare (%make-list-hash elt=)) + compare)) + +(define (%make-list-hash elt=) + (let ((elt-hash (equality-predicate-hasher elt=))) + (lambda (lset #!optional modulus) + (let ((hash + (apply + + (map (lambda (elt) + (elt-hash elt modulus)) + lset)))) + (if (default-object? modulus) + hash + (modulo hash modulus)))))) + +(define list-memoizer) +(define lset-memoizer) +(add-boot-init! + (lambda () + (set! list-memoizer (make-list-memoizer make-list= #f)) + (set! lset-memoizer (make-list-memoizer make-lset= #t)) + unspecific)) \ No newline at end of file diff --git a/src/runtime/predicate-metadata.scm b/src/runtime/predicate-metadata.scm index 2362511bc..f6149db4f 100644 --- a/src/runtime/predicate-metadata.scm +++ b/src/runtime/predicate-metadata.scm @@ -274,6 +274,7 @@ USA. (register-predicate! compiled-procedure? 'compiled-procedure '<= procedure?) (register-predicate! entity? 'entity '<= procedure?) (register-predicate! generic-procedure? 'generic-procedure '<= procedure?) + (register-predicate! memoizer? 'memoizer '<= apply-hook?) (register-predicate! primitive-procedure? 'primitive-procedure '<= procedure?) (register-predicate! procedure-arity? 'procedure-arity) @@ -292,6 +293,7 @@ USA. (register-predicate! environment? 'environment) (register-predicate! equality-predicate? 'equality-predicate '<= binary-procedure?) + (register-predicate! hash-table? 'hash-table) (register-predicate! interned-symbol? 'interned-symbol '<= symbol?) (register-predicate! keyword? 'keyword '<= symbol?) (register-predicate! lambda-tag? 'lambda-tag '<= symbol?) diff --git a/src/runtime/runtime.pkg b/src/runtime/runtime.pkg index 58cdbff0b..4f81ba65f 100644 --- a/src/runtime/runtime.pkg +++ b/src/runtime/runtime.pkg @@ -2305,6 +2305,21 @@ USA. strong-hash-table/constructor weak-hash-table/constructor)) +(define-package (runtime memoizer) + (files "memoizer") + (parent (runtime)) + (export () + all-args-memoizer + clear-memoizer! + list-memoizer + lset-memoizer + make-list-memoizer + make-memoizer + memoizer-table + memoizer-procedure + memoizer? + weak-eqv-memoizer)) + (define-package (runtime history) (files "histry") (parent (runtime))