--- a/src/wam/dump.lisp Wed Apr 20 17:13:31 2016 +0000
+++ b/src/wam/dump.lisp Wed Apr 20 21:04:27 2016 +0000
@@ -69,38 +69,70 @@
(e wam-environment-pointer)
(b wam-backtrack-pointer))
wam
- (when (not (= e b)) ; lame way to check for an empty stack...
- (loop :with n = nil
- :with limit = (max (+ e 3) (+ b 7))
+ (when (not (= 0 e b))
+ (loop :with nargs = nil
+ :with limit = (max (+ e 3) (+ b 7 2)) ; todo fix this limiting
:with arg = 0
- :for addr :from 0 :to limit
+ :with currently-in = nil
+ :for addr :from 0 :below limit
:for cell = (aref (wam-stack wam) addr)
:for offset = 0 :then (1+ offset)
:do
+ (when (not (zerop addr))
+ (switch (addr :test #'=)
+ (e (setf currently-in :frame offset 0 arg 0))
+ (b (setf currently-in :choice offset 0 arg 0))))
(format t " | ~4,'0X | ~8,'0X | ~30A|~A~A~%"
addr
cell
- (cond
- ((= offset 0) "CE ===========================")
- ((= offset 1) "CP")
- ((= offset 2)
- (if (zerop cell)
- (progn
- (setf offset -1)
- "N: EMPTY")
- (progn
- (setf n cell)
- (format nil "N: ~D" cell))))
- ((< arg n)
- (prog1
- (format nil " Y~D: ~4,'0X"
- arg
- ;; look up the actual cell in the heap
- (cell-aesthetic (wam-heap-cell wam cell)))
- (when (= n (incf arg))
- (setf offset -1
- n nil
- arg 0)))))
+ (case currently-in ; jesus christ this needs to get fixed
+ (:frame
+ (cond
+ ((= addr 0) "")
+ ((= offset 0) "CE ===========================")
+ ((= offset 1) "CP")
+ ((= offset 2)
+ (if (zerop cell)
+ (progn
+ (setf currently-in nil)
+ "N: EMPTY")
+ (progn
+ (setf nargs cell)
+ (format nil "N: ~D" cell))))
+ ((< arg nargs)
+ (prog1
+ (format nil " Y~D: ~4,'0X"
+ arg
+ ;; look up the actual cell in the heap
+ (cell-aesthetic (wam-heap-cell wam cell)))
+ (when (= nargs (incf arg))
+ (setf currently-in nil))))))
+ (:choice ; sweet lord make it stop
+ (cond
+ ((= addr 0) "")
+ ((= offset 0)
+ (if (zerop cell)
+ (progn
+ (setf currently-in nil)
+ "N: EMPTY =================")
+ (progn
+ (setf nargs cell)
+ (format nil "N: ~D =============" cell))))
+ ((= offset 1) "CE saved env pointer")
+ ((= offset 2) "CP saved cont pointer")
+ ((= offset 3) "CB previous choice")
+ ((= offset 4) "BP next clause")
+ ((= offset 5) "TR saved trail pointer")
+ ((= offset 6) "H saved heap pointer")
+ ((< arg nargs)
+ (prog1
+ (format nil " Y~D: ~4,'0X"
+ arg
+ ;; look up the actual cell in the heap
+ (cell-aesthetic (wam-heap-cell wam cell)))
+ (when (= nargs (incf arg))
+ (setf currently-in nil))))))
+ (t ""))
(if (= addr e) " <- E" "")
(if (= addr b) " <- B" "")))))
(format t " +------+----------+-------------------------------+~%"))
@@ -242,7 +274,7 @@
&optional
(from (max (- (wam-program-counter wam) 8) ; wow
0)) ; this
- (to (min (+ (wam-program-counter wam) 12) ; is
+ (to (min (+ (wam-program-counter wam) 8) ; is
(length (wam-code wam))))) ; bad
(format t "CODE~%")
(dump-code-store wam (wam-code wam) from to))
@@ -265,6 +297,14 @@
(defun dump-wam-functors (wam)
(format t " FUNCTORS: ~S~%" (wam-functors wam)))
+(defun dump-wam-trail (wam)
+ (format t " TRAIL: ")
+ (loop :for addr :across (wam-trail wam) :do
+ (format t "~4,'0X ~A //"
+ addr
+ (cell-aesthetic (wam-heap-cell wam addr))))
+ (format t "~%"))
+
(defun dump-labels (wam)
(format t "LABELS:~%~{ ~A -> ~4,'0X~^~%~}~%"
(loop :for functor-index
@@ -280,9 +320,10 @@
(format t " MODE: ~S~%" (wam-mode wam))
(dump-wam-functors wam)
(format t "HEAP SIZE: ~A~%" (length (wam-heap wam)))
- (format t "PROGRAM C: ~A~%" (wam-program-counter wam))
- (format t "CONT PTR: ~A~%" (wam-continuation-pointer wam))
- (format t "ENVIR PTR: ~A~%" (wam-environment-pointer wam))
+ (format t "PROGRAM C: ~4,'0X~%" (wam-program-counter wam))
+ (format t "CONT PTR: ~4,'0X~%" (wam-continuation-pointer wam))
+ (format t "ENVIR PTR: ~4,'0X~%" (wam-environment-pointer wam))
+ (dump-wam-trail wam)
(dump-wam-registers wam)
(format t "~%")
(dump-heap wam from to highlight)
--- a/src/wam/interpreter.lisp Wed Apr 20 17:13:31 2016 +0000
+++ b/src/wam/interpreter.lisp Wed Apr 20 21:04:27 2016 +0000
@@ -59,6 +59,51 @@
(cell-value functor-cell-2)))
+;;;; "Ancillary" Functions
+(defun* backtrack! ((wam wam) (reason string))
+ (:returns :void)
+ "Backtrack after a failure.
+
+ If `*break-on-fail*` is true, the debugger will be invoked.
+
+ "
+ (when *break-on-fail*
+ (break "FAIL: ~A" reason))
+ (if (zerop (wam-backtrack-pointer wam))
+ (setf (wam-fail wam) t)
+ (setf (wam-program-counter wam) (wam-stack-choice-bp wam)
+ (wam-backtracked wam) t))
+ (values))
+
+(defun* trail! ((wam wam) (address heap-index))
+ (:returns :void)
+ "Push the given address onto the trail (but only if necessary)."
+ (when (< address (wam-heap-backtrack-pointer wam))
+ (wam-trail-push! wam address))
+ (values))
+
+(defun* unbind! ((wam wam) (address heap-index))
+ (:returns :void)
+ "Unbind the reference cell at `address`.
+
+ No error checking is done, so please don't try to unbind something that's not
+ a reference cell.
+
+ "
+ (setf (wam-heap-cell wam address)
+ (make-cell-reference address))
+ (values))
+
+(defun* unwind-trail! ((wam wam)
+ (trail-start trail-index)
+ (trail-end trail-index))
+ (:returns :void)
+ "Unbind all the things in the given range of the trail."
+ ;; TODO: seriously can't we just pop back to a certain place?
+ (loop :for i :from trail-start :below trail-end :do
+ (unbind! wam (wam-trail-value wam i)))
+ (values))
+
(defun* deref ((wam wam) (address heap-index))
(:returns heap-index)
"Dereference the address in the WAM to its eventual destination.
@@ -85,28 +130,20 @@
"
(cond
+ ;; a1 <- a2
((unbound-reference-p wam address-1)
(setf (wam-heap-cell wam address-1)
- (make-cell-reference address-2)))
+ (make-cell-reference address-2))
+ (trail! wam address-1))
+ ;; a2 <- 1a
((unbound-reference-p wam address-2)
(setf (wam-heap-cell wam address-2)
- (make-cell-reference address-1)))
+ (make-cell-reference address-1))
+ (trail! wam address-2))
+ ;; wut
(t (error "At least one cell must be an unbound reference when binding.")))
(values))
-(defun* fail! ((wam wam) (reason string))
- (:returns :void)
- "Mark a failure in the WAM.
-
- If `*break-on-fail*` is true, the debugger will be invoked.
-
- "
- (setf (wam-fail wam) t)
- (when *break-on-fail*
- (break "FAIL: ~A~%" reason))
- (values))
-
-
(defun* unify! ((wam wam) (a1 heap-index) (a2 heap-index))
(wam-unification-stack-push! wam a1)
(wam-unification-stack-push! wam a2)
@@ -139,7 +176,7 @@
(wam-unification-stack-push! wam (+ structure-1-addr i))
(wam-unification-stack-push! wam (+ structure-2-addr i)))
;; Otherwise we're hosed.
- (fail! wam "Functors don't match in unify!")))))))))
+ (backtrack! wam "Functors don't match in unify!")))))))))
;;;; Instruction Definition
@@ -296,9 +333,9 @@
(if (matching-functor-p functor-cell functor)
(setf s (1+ functor-addr)
mode :read)
- (fail! wam "Functors don't match in get-struct"))))
- (t (fail! wam (format nil "get-struct on a non-ref/struct cell ~A"
- (cell-aesthetic cell))))))))
+ (backtrack! wam "Functors don't match in get-struct"))))
+ (t (backtrack! wam (format nil "get-struct on a non-ref/struct cell ~A"
+ (cell-aesthetic cell))))))))
(define-instructions (%unify-variable-local %unify-variable-stack)
((wam wam)
@@ -344,27 +381,29 @@
(define-instruction %call ((wam wam) (functor functor-index))
(let ((target (wam-code-label wam functor)))
(if target
- (progn
- (setf (wam-continuation-pointer wam) ; CP <- next instruction
- (+ (wam-program-counter wam)
- (instruction-size +opcode-call+))
- (wam-program-counter wam) ; PC <- target
- target))
- (fail! wam "Tried to call unknown procedure."))))
+ (setf (wam-continuation-pointer wam) ; CP <- next instruction
+ (+ (wam-program-counter wam)
+ (instruction-size +opcode-call+))
+
+ (wam-nargs wam) ; set NARGS
+ (wam-functor-arity wam functor)
+
+ (wam-program-counter wam) ; jump
+ target)
+ (backtrack! wam "Tried to call unknown procedure."))))
(define-instruction %proceed ((wam wam))
(setf (wam-program-counter wam) ; P <- CP
(wam-continuation-pointer wam)))
(define-instruction %allocate ((wam wam) (n stack-frame-argcount))
- ;; Use the slots directly here for speed. I know this sucks. I'm sorry.
+ ;; We use the slots directly here for speed. I know this sucks. I'm sorry.
(with-slots (stack environment-pointer) wam
- (let* ((old-e environment-pointer)
- (new-e (+ old-e (wam-stack-frame-size wam old-e))))
+ (let ((new-e (wam-stack-top wam)))
(wam-stack-ensure-size! wam (+ new-e 3 n))
- (setf (aref stack new-e) old-e ; E
- (aref stack (+ new-e 1) (wam-continuation-pointer wam)) ; CP
- (aref stack (+ new-e 2) n) ; N
+ (setf (aref stack new-e) environment-pointer ; CE
+ (aref stack (+ new-e 1)) (wam-continuation-pointer wam) ; CP
+ (aref stack (+ new-e 2)) n ; N
environment-pointer new-e)))) ; E <- new-e
(define-instruction %deallocate ((wam wam))
@@ -374,6 +413,60 @@
(wam-stack-frame-ce wam)))
+;;;; Choice Instructions
+(define-instruction %try ((wam wam) (next-clause code-index))
+ (with-slots (stack backtrack-pointer) wam
+ (let ((new-b (wam-stack-top wam))
+ (nargs (wam-nargs wam)))
+ (wam-stack-ensure-size! wam (+ new-b 7 nargs))
+ (setf (aref stack new-b) nargs ; N
+ (aref stack (+ new-b 1)) (wam-environment-pointer wam) ; CE
+ (aref stack (+ new-b 2)) (wam-continuation-pointer wam) ; CP
+ (aref stack (+ new-b 3)) (wam-backtrack-pointer wam) ; CB
+ (aref stack (+ new-b 4)) next-clause ; BP
+ (aref stack (+ new-b 5)) (wam-trail-pointer wam) ; TR
+ (aref stack (+ new-b 6)) (wam-heap-pointer wam) ; H
+ (wam-heap-backtrack-pointer wam) (wam-heap-pointer wam) ; HB
+ (wam-backtrack-pointer wam) new-b) ; B
+ (loop :for i :from 0 :below nargs :do ; A_i
+ (setf (wam-stack-choice-arg wam i new-b)
+ (wam-local-register wam i))))))
+
+(define-instruction %retry ((wam wam) (next-clause code-index))
+ (let ((b (wam-backtrack-pointer wam)))
+ ;; Restore argument registers
+ (loop :for i :from 0 :below (wam-stack-choice-n wam b) :do
+ (setf (wam-local-register wam i)
+ (wam-stack-choice-arg wam i b)))
+ (unwind-trail! wam (wam-stack-choice-tr wam b) (wam-trail-pointer wam))
+ (setf (wam-environment-pointer wam) (wam-stack-choice-ce wam b)
+ (wam-continuation-pointer wam) (wam-stack-choice-cp wam b)
+ ;; overwrite the next clause address in the choice point
+ (aref (wam-stack wam) (+ b 4)) next-clause
+ (wam-trail-pointer wam) (wam-stack-choice-tr wam b)
+ (wam-heap-pointer wam) (wam-stack-choice-h wam b)
+ (wam-heap-backtrack-pointer wam) (wam-heap-pointer wam))))
+
+(define-instruction %trust ((wam wam))
+ (let ((b (wam-backtrack-pointer wam)))
+ ;; Restore argument registers
+ (loop :for i :from 0 :below (wam-stack-choice-n wam b) :do
+ (setf (wam-local-register wam i)
+ (wam-stack-choice-arg wam i b)))
+ (unwind-trail! wam (wam-stack-choice-tr wam b) (wam-trail-pointer wam))
+ (setf (wam-environment-pointer wam) (wam-stack-choice-ce wam b)
+ (wam-continuation-pointer wam) (wam-stack-choice-cp wam b)
+ (wam-trail-pointer wam) (wam-stack-choice-tr wam b)
+ (wam-heap-pointer wam) (wam-stack-choice-h wam b)
+ (wam-backtrack-pointer wam) (wam-stack-choice-cb wam b)
+ ;; Note that this last one uses the NEW value of b, so the heap
+ ;; backtrack pointer gets set to the heap pointer saved in the
+ ;; PREVIOUS choice point.
+ ;;
+ ;; TODO: What if we just popped off the last stack frame?
+ (wam-heap-backtrack-pointer wam) (wam-stack-choice-h wam))))
+
+
;;;; Running
(defmacro instruction-call (wam instruction code-store pc number-of-arguments)
"Expand into a call of the appropriate machine instruction.
@@ -429,7 +522,7 @@
(defun extract-query-results (wam vars)
(let* ((addresses (loop :for var :in vars
:for i :from 0
- :collect (wam-stack-frame-arg wam i 0)))
+ :collect (wam-stack-frame-arg wam i)))
(results (extract-things wam addresses)))
(pairlis vars results)))
@@ -439,7 +532,7 @@
(defun run (wam &optional (step nil))
- (with-slots (code program-counter fail) wam
+ (with-slots (code program-counter fail backtrack) wam
(macrolet ((instruction (inst args)
`(instruction-call wam ,inst code program-counter ,args)))
(loop
@@ -449,6 +542,7 @@
:do
(block op
(when step
+ (dump) ; todo: make this saner
(break "About to execute instruction at ~4,'0X" program-counter))
(eswitch (opcode)
;; Query
@@ -471,6 +565,10 @@
(+opcode-get-variable-stack+ (instruction %get-variable-stack 2))
(+opcode-get-value-local+ (instruction %get-value-local 2))
(+opcode-get-value-stack+ (instruction %get-value-stack 2))
+ ;; Choice
+ (+opcode-try+ (instruction %try 1))
+ (+opcode-retry+ (instruction %retry 1))
+ (+opcode-trust+ (instruction %trust 0))
;; Control
(+opcode-allocate+ (instruction %allocate 1))
;; need to skip the PC increment for PROC/CALL/DEAL/DONE
@@ -486,7 +584,10 @@
(return-from op))
(+opcode-done+
(return-from run)))
- (incf program-counter (instruction-size opcode))
+ ;; Only increment the PC when we didn't backtrack
+ (if (wam-backtracked wam)
+ (setf (wam-backtracked wam) nil)
+ (incf program-counter (instruction-size opcode)))
(when (>= program-counter (fill-pointer code))
(error "Fell off the end of the program code store!")))))
(values)))
--- a/src/wam/wam.lisp Wed Apr 20 17:13:31 2016 +0000
+++ b/src/wam/wam.lisp Wed Apr 20 21:04:27 2016 +0000
@@ -53,6 +53,11 @@
:initform nil
:type boolean
:documentation "The failure register.")
+ (backtracked
+ :accessor wam-backtracked
+ :initform nil
+ :type boolean
+ :documentation "The backtracked register.")
(unification-stack
:reader wam-unification-stack
:initform (make-array 16
@@ -131,6 +136,9 @@
"Return the current heap pointer of the WAM."
(fill-pointer (wam-heap wam)))
+(defun (setf wam-heap-pointer) (new-value wam)
+ (setf (fill-pointer (wam-heap wam)) new-value))
+
(defun* wam-heap-cell ((wam wam) (address heap-index))
(:returns heap-cell)
@@ -147,6 +155,10 @@
"Return the current trail pointer of the WAM."
(fill-pointer (wam-trail wam)))
+(defun (setf wam-trail-pointer) (new-value wam)
+ (setf (fill-pointer (wam-trail wam)) new-value))
+
+
(defun* wam-trail-push! ((wam wam) (address heap-index))
(:returns (values heap-index trail-index))
"Push `address` onto the trail.
@@ -164,11 +176,25 @@
"Pop the top address off the trail and return it."
(vector-pop (wam-trail wam)))
+(defun* wam-trail-value ((wam wam) (address trail-index))
+ ;; TODO: can we really not just pop, or is something else gonna do something
+ ;; fucky with the trail?
+ (:returns heap-index)
+ "Return the element (a heap index) in the WAM trail at `address`."
+ (aref (wam-trail wam) address))
+
;;;; Stack
+;;; The stack is stored as a big ol' hunk of memory in a Lisp array with one
+;;; small glitch: we reserve the first word of the stack (address 0) to mean
+;;; "uninitialized", so we have a nice sentinal value for the various pointers
+;;; into the stack.
+
(defun* wam-stack-word ((wam wam) (address stack-index))
(:returns stack-word)
"Return the stack word at the given address."
+ (assert (not (zerop address)) (address)
+ "Cannot write to stack address zero.")
(aref (wam-stack wam) address))
(defun (setf wam-stack-word) (new-value wam address)
@@ -365,6 +391,25 @@
(+ (wam-stack-choice-n wam b) 7))
+(defun* wam-stack-top ((wam wam))
+ (:returns stack-index)
+ "Return the top of the stack.
+
+ This is the first place it's safe to overwrite in the stack.
+
+ "
+ ;; The book is wrong here -- it looks up the "current frame size" to
+ ;; determine where the next frame should start, but on the first allocation
+ ;; there IS no current frame so it looks at garbage. Fuckin' great.
+ (with-slots ((e environment-pointer) (b backtrack-pointer)) wam
+ (cond
+ ((= 0 b e) 1) ; first allocation
+ ((> e b) ; the last thing on the stack is a frame
+ (+ e (wam-stack-frame-size wam e)))
+ (t ; the last thing on the stack is a choice point
+ (+ b (wam-stack-choice-size wam b))))))
+
+
;;;; Resetting
(defun* wam-truncate-heap! ((wam wam))
(setf (fill-pointer (wam-heap wam)) 0))
@@ -383,7 +428,6 @@
(defun* wam-reset! ((wam wam))
(wam-truncate-heap! wam)
- (wam-truncate-stack! wam)
(wam-truncate-trail! wam)
(wam-truncate-unification-stack! wam)
(wam-reset-local-registers! wam)