memoize.lisp

;;; -*- Mode: LISP; Base: 10; Syntax: ANSI-COMMON-LISP; Package: (MEMOIZE) -*-
;; File              - memoize.lisp
;; Description       - memoization
;; Author            - Tim Bradshaw (tfb at lostwithiel)
;; Created On        - 1995?
;; Last Modified On  - Tue Jan 19 14:07:34 2021
;; Last Modified By  - Tim Bradshaw (tfb at kingston.fritz.box)
;; Update Count      - 15
;; Status            - Unknown
;;
;; $Id$
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

;;;; * Memoization
;;; Norvig p269-275

;;; memoize.lisp is copyright 1995-2000, 2021 by me, Tim Bradshaw, and may
;;; be used for any purpose whatsoever by anyone. It has no warranty
;;; whatsoever. I would appreciate acknowledgement if you use it in
;;; anger, and I would also very much appreciate any feedback or bug
;;; fixes.

;;; Note that memoized functions are not currently thread-safe, since
;;; calling them can modify the structure holding the memos.
;;;

(defpackage :org.tfeb.hax.memoize
  (:use :cl)
  (:export #:memoize-function
           #:unmemoize-function #:unmemoize-functions
           #:clear-memoized-function #:clear-memoized-functions
           #:function-memoized-p
           #:def-memoized-function
           #:memoized-labels))

(in-package :org.tfeb.hax.memoize)

(provide :org.tfeb.hax.memoize)

(defvar *memoized-functions* '()
  ;; stores an alist of (name table old-def)
  )

(defun make-memo (fn key test)
  ;; Return wrapper & table
  (declare (type function fn key test))
  (let ((table (make-hash-table :test test)))
    (values
      #'(lambda (&rest args)
          (declare (dynamic-extent args))
          (let ((k (funcall key args)))
            (multiple-value-bind (val found-p) (gethash k table)
              (if found-p
                  val
                  (setf (gethash k table)
                        (apply fn args))))))
      table)))

;;; semi user-interface fns

(defun memoize-function (fn-name &key (key #'first) (test #'eql))
  "Memoize FN-NAME, a function name, causing its results to be stashed

KEY is a function which is given the arglist of FN-NAME, and should
return a key to hash on for memoizing.  TEST is a function which the
test for the ashtable.  See Norvig P269-275.

Note this function may not work on self-recursive functions because
the compiler can optimize away self-calls in various ways.
DEF-MEMOIZED-FUNCTION should work for those cases as it is careful to
ensure the function can not be inlined like this."
  (declare (type (or symbol list) fn-name)
           (type function key test))
  (when (not (fboundp fn-name))
    (error "~A is not FBOUNDP" fn-name))
  (when (assoc fn-name *memoized-functions* :test #'equal)
    (error "~A is already memoized" fn-name))
  (multiple-value-bind (wrapper table)
      (make-memo (fdefinition fn-name) key test)
    (push (list fn-name table (fdefinition fn-name)) *memoized-functions*)
    (setf (fdefinition fn-name) wrapper)
    fn-name))

(defun unmemoize-function (fn-name)
  "Remove memoization for FN-NAME"
  (declare (type (or symbol list) fn-name))
  (let ((hit (assoc fn-name *memoized-functions* :test #'equal)))
    (when (not hit)
      (error "~A is not memoized" fn-name))
    (setf (fdefinition fn-name) (third hit))
    (setf *memoized-functions* (delete hit *memoized-functions*))
    fn-name))

(defun unmemoize-functions ()
  ;; complain about all the double-lookup & consing & I'll laugh at
  ;; you.
  "Unmemoize all functions"
  (mapcar #'unmemoize-function
          (mapcar #'car *memoized-functions*)))

(defun clear-memoized-function (fn-name)
  "Clear memoized results for FN-NAME"
  (declare (type (or symbol list) fn-name))
  (let ((hit (assoc fn-name *memoized-functions* :test #'equal)))
    (when (not hit)
      (error "~A is not memoized" fn-name))
    (clrhash (second hit))
    fn-name))

(defun clear-memoized-functions ()
  "Clear memoized results for all functions"
  (mapcar #'clear-memoized-function
          (mapcar #'car *memoized-functions*)))

(defun function-memoized-p (fn-name)
  "Is FN-NAME memoized?"
  (declare (type (or symbol list) fn-name))
  (if (assoc fn-name *memoized-functions* :test #'equal) t nil))

(defmacro def-memoized-function (fnspec args &body bod)
  "Define a memoized function.

FNSPEC is either the name of the function (names like (SETF x) are
OK), or a list suitable as an arglist for MEMOIZE-FUNCTION.  ARGS &
BOD are passed off to DEFUN.

This will declare FNSPEC NOTINLINE, which may be necessary to prevent
good compilers optimizing away self calls & stuff like that."
  ;; the sorts of fns that are usefully inlineable and those that are
  ;; usefully memoizable are probably disjoint...
  (let* ((normalized-fnspec (etypecase fnspec
                              (symbol (list fnspec))
                              (list (if (and (= (length fnspec) 2)
                                             (eq (first fnspec) 'setf))
                                        (list fnspec)
                                      fnspec))))
         (name (car normalized-fnspec)))
    (when (function-memoized-p name)
      (unmemoize-function name))
    `(progn
       ;; ??? is this right?  I want to ensure that the function is
       ;; really called, and avoid bright compilers doing TRO or not
       ;; calling through the SYMBOL-FUNCTION (kind of a strange thing
       ;; to want in general).  I think that a NOTINLINE declaration
       ;; does this.
       (declaim (notinline ,name))
       (defun ,name ,args
         ;; ??? can we need NOTINLINE here as well?
         ,@bod)
       (apply #'memoize-function (list ',(car normalized-fnspec)
                                       ,@(cdr normalized-fnspec)))
       ',name)))
#||
(def-memoized-function fib (n)
  (if (<= n 1)
      1
      (+ (fib (- n 1)) (fib (- n 2)))))
||#


(defmacro memoized-labels ((&rest labdefs) &body bod)
  "A version of LABELS that memoizes the local functions

See MEMOIZE-FUNCTION and DEF-MEMOIZED-FUNCTION.  If code that uses
this is compiled (either by COMPILE or COMPILE-FILE, then the table of
memoized results will be unique, if interpreted then a new table may
be generated for each use.  The function `names' are generalised in
the same way as for DEF-MEMOIZED-FUNCTION."
  ;; this is a pretty hairy macro, perhaps unnecessarily so.  It uses
  ;; an interestingly-large amount of the features of CL.  The use of
  ;; LOAD-TIME-VALUE is an attempt to get literal hashtables into the
  ;; compiled code, which seems to be non-portable the obvious way
  ;; (binding them in the macro & then splicing the literal in to the
  ;; expansion). Can MAKE-LOAD-FORM do this better?
  `(labels ,(loop for (fspec fargs . fbod) in labdefs
                  collect
                    (destructuring-bind (fname &key (key '(function first))
                                                    (test '(function eql)))
                        (if (and (listp fspec)
                                 (not (and (= (length fspec) 2)
                                           (eq (first fspec) 'setf))))
                            ;; FSPEC is of the form (NAME :key
                            ;; .. :test ..), where we use the keywords
                            ;; to get the key from the arglist and
                            ;; decide what test to use for the
                            ;; hashtable.
                            fspec
                            (list fspec :key '(function first)
                                  :test '(function eql)))
                      (let ((htn (make-symbol "HT"))    ;hashtable name
                            (kn (make-symbol "K"))      ;key from arglist name
                            (vn (make-symbol "V"))      ;value found name
                            (fpn (make-symbol "FP"))    ;foundp name
                            (argsn (make-symbol "ARGS")))       ;args name
                        ;; here's the definition clause in the LABELS:
                        ;; note we have to generalise rthe args to an
                        ;; &REST, but hopefully the DYNAMIC-EXTENT
                        ;; avoids too much lossage.
                        `(,fname (&rest ,argsn)
                          (declare (dynamic-extent ,argsn)      ;stop consing
                                   (notinline ,fname))  ;stop TRO (?)
                          ;; this use of LOAD-TIME-VALUE should ensure
                          ;; that the hashtable is unique in compiled
                          ;; code.  This has kind of interesting
                          ;; effects, as it's shared amongst seperate
                          ;; closures that you might return, so use of
                          ;; one can speed up another!
                          (let ((,htn (load-time-value (make-hash-table
                                                         :test ,test)))
                                (,kn (funcall ,key ,argsn)))
                            (multiple-value-bind (,vn ,fpn)
                                (gethash ,kn ,htn)
                              (if ,fpn
                                  ,vn           ;found in table: return value
                                  ;; didn't find it: compute value
                                  (setf (gethash ,kn ,htn)
                                        (apply #'(lambda ,fargs
                                                   ,@fbod)
                                               ,argsn)))))))))
     ,@bod))

;;; indentation for zmacs
#+Genera
(pushnew 'memoized-labels zwei:*definition-list-functions*)