;;; -*- Syntax:Common-Lisp; Mode: LISP; Package: (TMS GLOBAL 1000.); Base: 10. -*- (in-package 'tms) "(c) Copyright 1986, 1987, 1988, 1989, 1990, 1991 Xerox Corporation. All rights reserved. Subject to the following conditions, permission is granted to use and copy this software and to prepare derivative works: Such use, copying or preparation of derivative works must be for non-commercial research or educational purposes; each copy or derivative work must include this copyright notice in full; a copy of each completed derivative work must be returned to: DEKLEER@XEROX.COM (Arpanet) or Johan de Kleer, Xerox PARC, 3333 Coyote Hill Road, Palo Alto, CA 94304. This software is made available AS IS, and Xerox Corporation makes no warranty about the software or its performance." ;;; o Storing hashes themselves in the table is not worth it. It never seems to miss ;;; therefore, I might as well reduce the table size by 30%. ;;; o Install env-gc for at least flushing inactive envs. See rehash-env below. ;;; o What about true/false assumptions in make-environments? or other ;;; ATMS calls. The ATMS does not check in passed in arguments of inactive envs. ;;; o The clever array referencing stuff here doesn't seem to buy us much. Think ;;; this out more clearly sometime. ;;; o Look at RMS Lisp manual for ways to make bitvectors arrays. Unfortunately, that ;;; won't necessarily work on a 3600 so maybe it is not worth it. ;;; o Use hash-statistics on a big problem. It looks as if storing the hash is a ;;; worthless exercise. Given the size of the env hash array, we would have 30% ;;; right off the top if we did that. ;;; o Contradictory environments might be in hash table, but there without an environment ;;; structure, just a key. Thats sort of how it works right now anyway, but they ;;; can now be removed after the fact too.... I guess this is only important if ;;; if we start testing the envs keys themselves and shorten the env vectors even more. ;;; o Rehashing should garbage collect unused assumptions, environment using unused ;;; assumptions, any environment containing a true or false assumption. ;;; This uses an algorithm suggested by Danny Bobrow (blame him). (defvar *good-double-primes* '(103 139 181 229 283 349 433 523 619 811 1021 1231 1453 1621 1849 2029 2341 2713 2971 3529 4003 4423 5023 5503 6091 6553 7129 7591 8221 8971 9631 10273 14983 16063 17029 18043 19081 20023 22039 24109 25999 28099 30013 33073 36013 39841 45007 50021 55001 66029 79229 95063 114067 136859 164231 200003 240007 345601 414721 497671 597209 800011 960017 1440037 1728043 2073647 2488379 2986037 3583271)) ;;; This finds a prime above n extremely stupidly. (defun fprime (n &aux primes end) (setq primes (list 2) end primes) (do ((i 3. (1+ i))) (nil) (cond ((dolist (p primes) (if (> (* p p) i) (return NIL)) (if (= (rem i p) 0) (return T)))) (t (rplacd end (list i)) (setq end (cdr end)) (cond ((> i n) (format T "~% ~D" i) (setq n (floor (* 1.2 n))))))))) ;;; Don't allow utilization to go above 75%. (defun make-hash-table-env (size area &aux hash-table) (do ((p1 *good-double-primes* (cdr p1)) (p2 (cdr *good-double-primes*) (cdr p2))) ((null p2) (error "Sorry I'm out of good primes")) (when (> (car p2) size) (setq hash-table (make-hash :P1 (car p1) :P2 (car p2) :PRIMES (cdr p2) :FREE (car p2) :THRESH (floor (* .25 (car p2))) :ARRAY (fast-make-array (car p2) area) :AREA area)) (setf (hash-array-loc hash-table) #+(OR :CADR :CL-ZL :ZL) (aloc (hash-array hash-table) 0) #+:CL (hash-array hash-table)) (return hash-table)))) ;;; Sort of strange, but makes thing simpler. (defun copy-hash-table-env (hash-table &aux new-hash-table) (setq new-hash-table (copy-hash hash-table)) (setf (hash-array new-hash-table) (fast-make-array (hash-p2 new-hash-table) (hash-area new-hash-table))) (setf (hash-array-loc new-hash-table) #+(OR :CADR :CL-ZL :ZL) (aloc (hash-array new-hash-table) 0) #+:CL (hash-array new-hash-table)) (setf (hash-free new-hash-table) (hash-p2 hash-table)) new-hash-table) (defun reset-hash-table-env (table) (fill (hash-array table) nil) (setf (hash-free table) (hash-p2 table))) ;;; This returns a raw pointer if possible, otherwise an integer offset. (defmacro hloc (array offset) array #+(OR :CL :IL) `,offset #+(OR :CL-ZL :CADR :ZL) `(aloc ,array ,offset)) ;;; Slot is either (1) an ENV defstruct. ;;; (2) vector if its an inconsistent entry. (defun puthash-env (key value hash-table &aux i slot p1) (let* ((baseloc (hash-array-loc hash-table)) (p2 (hash-p2 hash-table)) (p (hash key p2))) #+:Symbolics (declare (sys:array-register baseloc)) (do nil (nil) (setq slot (fast-aref baseloc p)) (cond ((null slot) (fast-aset value baseloc p) (if (< (decf (hash-free hash-table)) (hash-thresh hash-table)) (maybe-rehash-env hash-table)) (return value)) ((listp slot) (when (vector-equal key slot) (fast-aset value baseloc p) (return value))) ((vector-equal key (env-vector slot)) (fast-aset value baseloc p) (return value))) (unless i (setq p1 (hash-p1 hash-table)) (if (= 0 (setq i (rem p p1))) (setq i p1))) (incf p i) (if (>= p p2) (decf p p2))))) ;;; This returns the environment if it is found, otherwise it returns an array offset ;;; to the empty slot. This now only returns a locative if the slot is empty. (defun nget-or-puthash-env (key hash-table &optional dont-allocate &aux i p1 slot) (let* ((baseloc (hash-array-loc hash-table)) (p2 (hash-p2 hash-table)) (p (hash key p2))) #+:Symbolics (declare (sys:array-register baseloc)) (do nil (nil) (setq slot (fast-aref baseloc p)) (cond ((null slot) (cond ((and (not dont-allocate) (< (decf (hash-free hash-table)) (hash-thresh hash-table))) (maybe-rehash-env hash-table) (return (nget-or-puthash-env key hash-table dont-allocate))) (t (return (hloc baseloc p))))) ((listp slot) (if (vector-equal key slot) (return *contra-env*))) ((vector-equal key (env-vector slot)) (return slot))) (unless i (setq p1 (hash-p1 hash-table)) (if (= 0 (setq i (rem p p1))) (setq i p1))) (incf p i) (if (>= p p2) (decf p p2))))) ;;; Use if you called nget-or-puthash-env with dont-allocate set to T and you changed ;;; your mind. (defun hash-allocate (hash-table) (if (< (decf (hash-free hash-table)) (hash-thresh hash-table)) (maybe-rehash-env hash-table))) ;;; If gethash-env misses, it returns as a second argument what nget-or-puthash-env would. (defun gethash-env (key hash-table &aux i p1 slot) (let* ((baseloc (hash-array-loc hash-table)) (p2 (hash-p2 hash-table)) (p (hash key p2))) #+:Symbolics (declare (sys:array-register baseloc)) (do nil (nil) (setq slot (or (fast-aref baseloc p) (return nil))) (if (listp slot) (if (vector-equal key slot) (return *contra-env*)) (if (vector-equal key (env-vector slot)) (return slot))) (unless i (setq p1 (hash-p1 hash-table)) (if (= 0 (setq i (rem p p1))) (setq i p1))) (incf p i) (if ( p p2) (decf p p2))))) (defvar *compress-env-table* T) ;;; Call this function whenever you want. Usually called when free space ;;; in hash table gets low. To prevent thrashing this ensures that 1.5 threshold ;; table is free before this function is necessarily called again. (defun maybe-rehash-env (hash-table) (format T "~% GC ing because the hash table is ~D% full" (// (* (- (hash-p2 hash-table) (hash-free hash-table)) 100.) (hash-p2 hash-table))) (rehash-env hash-table *compress-env-table*) (format T "~% After GC the hash table is ~D% full" (// (* (- (hash-p2 hash-table) (hash-free hash-table)) 100.) (hash-p2 hash-table))) (unless (and *compress-env-table* (> (hash-free hash-table) (* 1.5 (hash-thresh hash-table)))) (rehash-env hash-table nil t)) hash-table) ;;; Could replace all false environemnts with their bitstrings. But that may not be ;;; a good idea because it'll make binary subsumption tests hard. ;;; This throws away any ENV which is subsumed by a binary nogood. ;;; This throws away any ENV which is no longer active. (defun rehash-env (hash-table &optional nogrowthp keep-everything &aux new-hash-table p3 start-time key p2 p i p1 slot) (format T "~%Rehashing ") (if nogrowthp (format T " for GC only") (format T " for more space ...")) (setq start-time (get-internal-run-time) new-hash-table (if nogrowthp (copy-hash-table-env hash-table) (make-hash-table-env (floor (* 1.5s0 (hash-p2 hash-table))) (hash-area hash-table)))) (format T "~D seconds to create array" (time-taken start-time)) (let ((ptr (hash-array-loc hash-table)) (baseloc (hash-array-loc new-hash-table))) #+:Symbolics (declare (sys:array-register ptr baseloc)) (setq p3 0 p1 (hash-p1 new-hash-table) p2 (hash-p2 new-hash-table)) (dotimes (k (hash-p2 hash-table)) (setq slot (fast-aref ptr p3)) (cond ((null slot)) ((and (not keep-everything) (if (listp slot) (vector-flush? slot) (or (subsumed-by-binary-nogood? slot) (not (active-env? slot)))))) (t (setq i nil key (if (listp slot) slot (env-vector slot)) p (hash key p2)) (do nil (nil) ;; Guaranteed not to hit twice... (unless (fast-aref baseloc p) (fast-aset slot baseloc p) (decf (hash-free new-hash-table)) (return)) (unless i (if (= 0 (setq i (rem p p1))) (setq i p1))) (incf p i) (if ( p p2) (decf p p2))))) (incf p3)) (replace hash-table new-hash-table) (format T "~D seconds total." (time-taken start-time)))) ;;; Test to see just how much it costs to scan the hash table. (defun scan (hash-table &aux p3 start-time count) (setq start-time (get-internal-run-time) p3 0 count 0) (let ((ptr (hash-array-loc hash-table))) #+:CL-ZL (declare (sys:array-register ptr)) (dotimes (k (hash-p2 hash-table)) (if (fast-aref ptr k) (incf count))) (format T "~D entries, ~D s for scan." count (time-taken start-time)))) (defun bignums? (hash-table &aux env) (let ((ptr (hash-array-loc hash-table))) #+:CL-ZL (declare (sys:array-register ptr)) (dotimes (k (hash-p2 hash-table)) (setq env (fast-aref ptr k)) (cond ((null env)) ((listp env)) (t (dolist (w (env-vector env)) (if (typep w 'BIGNUM) (error "Bignum it bit vector?")))))))) (defconstant *max-probe* 200.) ;;; Used for debugging. (defun hash-statistics (table &aux probe-array entries key probes max-probe p1 p2 actives array alist item hash contra-count slot subsumed-nogoods subsumed-by-binary-nogoods) (setq p1 (hash-p1 table) p2 (hash-p2 table) subsumed-by-binary-nogoods 0 subsumed-nogoods 0 contra-count 0 array (hash-array-loc table) probe-array (make-array *max-probe* :ELEMENT-TYPE (list 'INTEGER 0 (- p2 (hash-free table))) :INITIAL-ELEMENT 0) actives 0 entries 0 probes 0 max-probe 0) (format T "~% Hash array is ~D words long." p2) (do ((p 0 (1+ p))) ((>= p (array-length array))) (setq slot (aref array p)) (when slot (incf entries) ;; *** could be subumsed and we don't know it. (cond ((listp slot) ;;** suboptimal here: (if (vector-subsumed-by-binary-nogood? slot) (incf subsumed-by-binary-nogoods)) (if (active-vector? slot) (incf actives)) (setq key slot) (incf contra-count)) (t (if (subsumed-nogood? slot) (incf subsumed-nogoods)) (if (subsumed-by-binary-nogood? slot) (incf subsumed-by-binary-nogoods)) (setq key (env-vector slot)) (if (active-env? slot) (incf actives)))) (multiple-value-bind (ignore probe-test) (igethash-env key table) (incf probes probe-test) (if (>= probe-test *max-probe*) (setq probe-test *max-probe*)) (if (> probe-test max-probe) (setq max-probe probe-test)) (incf (aref probe-array (1- probe-test)))))) (format T "~% The hash table is ~D% full" (// (* entries 100.) p2)) (unless (= entries (- p2 (hash-free table))) (format T "~% Free count of hash table is wrong.")) (format T "~% There are ~D entries, of which ~D are active." entries actives) (if (= entries 0) (return-from HASH-STATISTICS nil)) (format T "~% And ~D are indicated by contradictory vectors" contra-count) (format T "~% And ~D subsumed nogood ENVs" subsumed-nogoods) (format T "~% And ~D of those are subsumed by binary nogoods" subsumed-by-binary-nogoods) (format T "~% Average probe ~D" (/ (float probes) entries)) (format T "~% Worst probe was ~D" max-probe) (dotimes (i max-probe) (format T "~% ~D % (~D) probes of length ~D" (if (= 0 (aref probe-array i)) 0 (// (* (aref probe-array i) 100.) entries)) (aref probe-array i) (1+ i))) (do ((p 0 (1+ p))) ((>= p (array-length array))) (setq slot (aref array p)) (when slot (setq hash (if (listp slot) (hash slot p2) (hash (env-vector slot) p2)) item (assq hash alist)) (if item (rplacd item (cons p (cdr item))) (push (list hash p) alist)))) (format T "~%On average, ~D keys had same initial probe." (// entries (length alist))) (setq alist (mapcar #'(lambda (item) (cons (1- (length item)) (cdr item))) alist)) ;;;*** flush the ones here, don't sort them.*** (setq alist (sort alist #'(lambda (a b) (> (car a) (car b))))) (dolist (item alist) (when (> (car item) 1) (format T "~%~D different keys have identical hash:~O" (car item) (aref array (cadr item))) (dolist (p (cdr item)) (format T "~%Key: ~O" (aref array p))))) alist) ;;; Inefficient version, but may be ok. (defun vector-subsumed-by-binary-nogood? (vector) (dolist (a (nnvector-assumptions vector)) (if (vector-intersection? vector (assumption-binary-vector a)) (return T)))) ;;; Is the environment subsumed by a binary nogood? Remember the hash table ;;; has only environments of 2 or more assumptions in it. (defun subsumed-by-binary-nogood? (env &aux vector base) (when (subsumed-nogood? env) (setq base (cdr (env-contradictory-info env))) (do nil ((null (subsumed-nogood? base))) (setq base (cdr (env-contradictory-info base)))) (if (< (env-count base) 3.) (return-from SUBSUMED-BY-BINARY-NOGOOD? T)) (setq vector (env-vector env)) (dolist (a (env-assumptions-delay env)) (if (vector-intersection? vector (assumption-binary-vector a)) (return T))))) (defun checking (env &aux vector) (setq vector (env-vector env)) (dolist (a (env-assumptions env)) (if (vector-intersection? vector (assumption-binary-vector a)) (return T)))) ;;; Should the vector be removed from hash table? If its subsumed by a binary ;;; nogood or when one of its assumptions is true or false. This is slightly ;;; slower than calling nnvector-assumptions, but doesn't GC. (defun vector-flush? (vector) (do-assumptions-blits vector #'(lambda (a) #+Symbolics (declare (sys:downward-function)) (when (or (i-true? a) (i-false? a) (vector-intersection? vector (assumption-binary-vector a))) (return-from vector-flush? T)))) nil) ;(defun vector-flush? (vector) ; (dolist (a (nnvector-assumptions vector)) ; (when (or (i-true? a) (i-false? a) ; (vector-intersection? vector (assumption-binary-vector a))) ; (return-from vector-flush? T)))) ; nil) (defun active-vector? (vector) (not (dolist (a (nnvector-assumptions vector)) (if (i-true? a) (return T)) (if (i-false? a) (return T))))) ;;; An environment is active, only if none of its assumptions are true or false. (defun active-env? (e) (not (dolist (a (env-assumptions-delay e)) (if (i-true? a) (return T)) (if (i-false? a) (return T))))) ;;; Instruemented gethash-env, used to see how bad things are. ;;; Returns probes. (defun igethash-env (key hash-table &aux i p1 slot) (let* ((p2 (hash-p2 hash-table)) (p (hash key p2)) (baseloc (hash-array-loc hash-table)) (probes 0)) #+:Symbolics (declare (sys:array-register baseloc)) (do nil (nil) (incf probes) (setq slot (fast-aref baseloc p)) (cond ((null slot) (error "key not found?")) ((listp slot) (if (vector-equal key slot) (return (values slot probes)))) ((vector-equal key (env-vector slot)) (return (values slot probes)))) (unless i (setq p1 (hash-p1 hash-table)) (if (= 0 (setq i (rem p p1))) (setq i p1))) (incf p i) (if (>= p p2) (decf p p2)))))