--- 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
--- 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
--- 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))))))
+
--- 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
--- 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+))
--- 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)
--- 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!