# HG changeset patch # User Steve Losh # Date 1461186267 0 # Node ID a97a1fd92f94134e00a8ae45e3022a744356c8dd # Parent dc6892a9a406182a7fc88c33918c683d08bc9474 Implement choice points and backtracking Holy shit I've got a Prolog diff -r dc6892a9a406 -r a97a1fd92f94 src/wam/dump.lisp --- 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) diff -r dc6892a9a406 -r a97a1fd92f94 src/wam/interpreter.lisp --- 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))) diff -r dc6892a9a406 -r a97a1fd92f94 src/wam/wam.lisp --- 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)