# HG changeset patch # User Steve Losh # Date 1468619754 0 # Node ID a8598eafe403720f1ad8e140cac584e38808a53c # Parent 9d42a27624fd01ea8f4480452133c1f3711ee3ea Remove the god damn functor table It's happening^Whappened! diff -r 9d42a27624fd -r a8598eafe403 package.lisp --- a/package.lisp Fri Jul 15 20:43:32 2016 +0000 +++ b/package.lisp Fri Jul 15 21:55:54 2016 +0000 @@ -18,6 +18,7 @@ #:megabytes #:ecase/tree #:gethash-or-init + #:aref-or-init #:define-lookup #:queue #:make-queue diff -r 9d42a27624fd -r a8598eafe403 src/make-quickutils.lisp --- a/src/make-quickutils.lisp Fri Jul 15 20:43:32 2016 +0000 +++ b/src/make-quickutils.lisp Fri Jul 15 21:55:54 2016 +0000 @@ -10,7 +10,6 @@ :while :until :tree-member-p - :tree-collect :with-gensyms :once-only :zip diff -r 9d42a27624fd -r a8598eafe403 src/utils.lisp --- a/src/utils.lisp Fri Jul 15 20:43:32 2016 +0000 +++ b/src/utils.lisp Fri Jul 15 21:55:54 2016 +0000 @@ -84,7 +84,7 @@ (recur ,@(mapcar #'extract-val bindings))))) (defmacro gethash-or-init (key hash-table default-form) - "Get the a key's value in a hash table, initializing if necessary. + "Get `key`'s value in `hash-table`, initializing if necessary. If `key` is in `hash-table`: return its value without evaluating `default-form` at all. @@ -102,6 +102,21 @@ ,value (setf (gethash ,key ,hash-table) ,default-form)))))) +(defmacro aref-or-init (array index default-form) + "Get `index` in `array`, initializing if necessary. + + If `index` is non-nil in `array`: return its value without evaluating + `default-form` at all. + + If `index` is nil in `array`: evaluate `default-form` and set it before + returning it. + + " + ;; TODO: think up a less shitty name for this + (once-only (index array) + `(or (aref ,array ,index) + (setf (aref ,array ,index) ,default-form)))) + (defmacro array-push (value array pointer &environment env) "Push `value` onto `array` at `pointer`, incrementing `pointer` afterword. @@ -240,3 +255,4 @@ (let (($keyform (gensym "CASE/TREE-"))) `(let ((,$keyform ,keyform)) ,(%case/tree $keyform (sort (copy-list cases) #'< :key #'first)))))) + diff -r 9d42a27624fd -r a8598eafe403 src/wam/compiler/5-precompilation.lisp --- a/src/wam/compiler/5-precompilation.lisp Fri Jul 15 20:43:32 2016 +0000 +++ b/src/wam/compiler/5-precompilation.lisp Fri Jul 15 21:55:54 2016 +0000 @@ -201,7 +201,7 @@ ;; OP functor reg (push destination-register seen) (push-instruction (find-opcode-structure mode) - (wam-unique-functor wam (cons functor arity)) + (cons functor arity) destination-register)) (handle-list (register) (push register seen) @@ -221,7 +221,7 @@ ;; [CALL/JUMP] functor (push-instruction (if is-jump :jump :call) - (wam-unique-functor wam (cons functor arity)))) + (cons functor arity))) ;; This is a little janky, but at this point the body goals have been ;; turned into one single stream of tokens, so we don't have a nice ;; clean way to tell when one ends. But in practice, a body goal is diff -r 9d42a27624fd -r a8598eafe403 src/wam/dump.lisp --- a/src/wam/dump.lisp Fri Jul 15 20:43:32 2016 +0000 +++ b/src/wam/dump.lisp Fri Jul 15 21:55:54 2016 +0000 @@ -266,6 +266,18 @@ (first arguments))) +(defun functor-table (wam) + (loop + :with result = (make-hash-table) + :for arity :from 0 + :for table :across (wam-code-labels wam) + :when table + :do (maphash (lambda (functor loc) + (setf (gethash loc result) + (cons functor arity))) + table) + :finally (return result))) + (defun dump-code-store (wam code-store &optional (from 0) @@ -275,7 +287,7 @@ ;; aren't aligned. So if we just start at `from` we might start in the middle ;; of an instruction and everything would be fucked. (let ((addr 0) - (lbls (bones.utils::invert-hash-table (wam-code-labels wam)))) ; oh god + (lbls (functor-table wam))) ; oh god (while (< addr to) (let ((instruction (retrieve-instruction code-store addr))) (when (>= addr from) @@ -320,8 +332,6 @@ (dump-cell-value value) (format nil "; ~A" (first (extract-things wam (list register))))))) -(defun dump-wam-functors (wam) - (format t " FUNCTORS: ~S~%" (wam-functors wam))) (defun dump-wam-trail (wam) (format t " TRAIL: ") @@ -329,19 +339,11 @@ (format t "~8,'0X //" address)) (format t "~%")) -(defun dump-labels (wam) - (format t "LABELS:~%~{ ~A -> ~4,'0X~^~%~}~%" - (loop :for functor - :being :the :hash-keys :of (wam-code-labels wam) - :using (hash-value address) - :nconc (list (pretty-functor functor) address)))) - (defun dump-wam (wam from to) (format t " FAIL: ~A~%" (wam-fail wam)) (format t " BACKTRACKED?: ~A~%" (wam-backtracked wam)) (format t " MODE: ~S~%" (wam-mode wam)) - (dump-wam-functors wam) (format t " HEAP SIZE: ~A~%" (- (wam-heap-pointer wam) +heap-start+)) (format t " PROGRAM COUNTER: ~4,'0X~%" (wam-program-counter wam)) (format t "CONTINUATION PTR: ~4,'0X~%" (wam-continuation-pointer wam)) @@ -356,7 +358,6 @@ (format t "~%") (dump-stack wam) (format t "~%") - (dump-labels wam) (dump-code wam)) (defun dump-wam-query-code (wam &optional (max +maximum-query-size+)) diff -r 9d42a27624fd -r a8598eafe403 src/wam/vm.lisp --- a/src/wam/vm.lisp Fri Jul 15 20:43:32 2016 +0000 +++ b/src/wam/vm.lisp Fri Jul 15 21:55:54 2016 +0000 @@ -48,12 +48,12 @@ (defun* functors-match-p ((f1 functor) (f2 functor)) (:returns boolean) "Return whether the two functor cell values represent the same functor." - (eq f1 f2)) + (equal f1 f2)) (defun* constants-match-p ((c1 functor) (c2 functor)) (:returns boolean) "Return whether the two constant cell values unify." - (eq c1 c2)) + (equal c1 c2)) (defun* lisp-objects-match-p ((o1 t) (o2 t)) (:returns boolean) @@ -489,7 +489,7 @@ (functor functor) (program-counter-increment instruction-size) (is-tail boolean)) - (let* ((target (wam-code-label wam functor))) + (let* ((target (wam-code-label wam (car functor) (cdr functor)))) (if (not target) ;; Trying to call an unknown procedure. (backtrack! wam) diff -r 9d42a27624fd -r a8598eafe403 src/wam/wam.lisp --- a/src/wam/wam.lisp Fri Jul 15 20:43:32 2016 +0000 +++ b/src/wam/wam.lisp Fri Jul 15 21:55:54 2016 +0000 @@ -71,14 +71,8 @@ :type (simple-array code-word (*)) :read-only t) (code-labels - (make-hash-table :test 'eq) - :read-only t) - (functors - (make-array 64 - :fill-pointer 0 - :adjustable t - :element-type 'functor) - :type (vector functor) + (make-array +maximum-arity+ :initial-element nil) + :type (simple-array (or null hash-table)) :read-only t) ;; Logic Stack @@ -727,6 +721,16 @@ ;;;; Code +;;; The WAM needs to be able to look up predicates at runtime. To do this we +;;; keep a data structure that maps a functor and arity to a location in the +;;; code store. +;;; +;;; This data structure is an array, with the arity we're looking up being the +;;; position. At that position will be a hash tables of the functor symbols to +;;; the locations. +;;; +;;; Each arity's table will be created on-the-fly when it's first needed. + (defun* retrieve-instruction (code-store (address code-index)) "Return the full instruction at the given address in the code store." (make-array (instruction-size (aref code-store address)) @@ -735,19 +739,29 @@ :adjustable nil :element-type 'code-word)) -(defun* wam-code-label ((wam wam) (functor functor)) + +(defun* wam-code-label ((wam wam) (functor fname) (arity arity)) (:returns (or null code-index)) - (gethash functor (wam-code-labels wam))) + (let ((atable (aref (wam-code-labels wam) arity))) + (when atable + (values (gethash functor atable))))) (defun* (setf wam-code-label) ((new-value code-index) (wam wam) (functor fname) (arity arity)) - ;; Note that this takes a functor/arity and not a cons. - (setf (gethash (wam-unique-functor wam (cons functor arity)) - (wam-code-labels wam)) + (setf (gethash functor (aref-or-init (wam-code-labels wam) arity + (make-hash-table :test 'eq))) new-value)) +(defun* wam-code-label-remove! ((wam wam) + (functor fname) + (arity arity)) + (let ((atable (aref (wam-code-labels wam) arity))) + (when atable + ;; todo: remove the table entirely when empty? + (remhash functor atable)))) + (defun* wam-load-query-code! ((wam wam) (query-code query-code-holder)) @@ -767,10 +781,13 @@ ;;; of logic frames to reuse, which lets us simply `clrhash` in between instead ;;; of having to allocate a brand new hash table. +(declaim (inline assert-logic-frame-poppable)) + + (defstruct logic-frame (start 0 :type code-index) (final nil :type boolean) - (predicates (make-hash-table) :type hash-table)) + (predicates (make-hash-table :test 'equal) :type hash-table)) (defun* wam-logic-pool-release ((wam wam) (frame logic-frame)) @@ -816,24 +833,36 @@ (push frame (wam-logic-stack wam))) (values)) +(defun assert-logic-frame-poppable (wam) + (let ((logic-stack (wam-logic-stack wam))) + (policy-cond:policy-if (or (> safety 1) (> debug 0) (< speed 3)) + ;; Slow + (progn + (assert logic-stack () + "Cannot pop logic frame from an empty logic stack.") + (assert (logic-frame-final (first logic-stack)) () + "Cannot pop unfinalized logic frame.")) + ;; Fast + (when (or (not logic-stack) + (not (logic-frame-final (first logic-stack)))) + (error "Cannot pop logic frame."))))) + (defun* wam-pop-logic-frame! ((wam wam)) (:returns :void) (with-slots (logic-stack) wam - (assert logic-stack () - "Cannot pop logic frame from an empty logic stack.") - (assert (logic-frame-final (first logic-stack)) () - "Cannot pop unfinalized logic frame.") + (assert-logic-frame-poppable wam) (let ((frame (pop logic-stack))) (setf (wam-code-pointer wam) (logic-frame-start frame)) - (loop :for label :being :the hash-keys :of (logic-frame-predicates frame) - :do (remhash label (wam-code-labels wam))) + (loop :for (functor . arity) + :being :the hash-keys :of (logic-frame-predicates frame) + :do (wam-code-label-remove! wam functor arity)) (wam-logic-pool-release wam frame))) (values)) -(defun* assert-label-not-already-compiled ((wam wam) clause label) - (assert (not (wam-code-label wam label)) +(defun* assert-label-not-already-compiled ((wam wam) clause functor arity) + (assert (not (wam-code-label wam functor arity)) () "Cannot add clause ~S because its predicate has preexisting compiled code." clause)) @@ -842,12 +871,13 @@ (assert (wam-logic-open-p wam) () "Cannot add clause ~S without an open logic stack frame." clause) + (multiple-value-bind (functor arity) (find-predicate clause) - (let ((label (wam-unique-functor wam (cons functor arity)))) - (assert-label-not-already-compiled wam clause label) - (with-slots (predicates) - (wam-current-logic-frame wam) - (enqueue clause (gethash-or-init label predicates (make-queue)))))) + (assert-label-not-already-compiled wam clause functor arity) + (enqueue clause (gethash-or-init + (cons functor arity) + (logic-frame-predicates (wam-current-logic-frame wam)) + (make-queue)))) (values)) @@ -992,22 +1022,6 @@ (wam-copy-store-cell! wam (wam-stack-register-address wam destination) source)) -;;;; Functors -;;; Functors are stored in an adjustable array to uniquify them... for now. - -(defun* wam-unique-functor ((wam wam) (functor functor)) - (:returns functor) - "Return a unique version of the functor cons. - - If the functor is not already in the table it will be added. - - " - (or (find functor (wam-functors wam) :test #'equal) - (progn - (vector-push-extend functor (wam-functors wam)) - functor))) - - ;;;; Unification Stack (declaim (inline wam-unification-stack-push! wam-unification-stack-pop!