--- a/package-test.lisp Mon Jul 11 23:37:37 2016 +0000
+++ b/package-test.lisp Tue Jul 12 15:46:22 2016 +0000
@@ -33,6 +33,8 @@
#:?
#:query
#:query-all)
+ (:import-from #:bones.utils
+ #:symbolize)
(:shadowing-import-from #:bones.wam
#:!))
--- a/package.lisp Mon Jul 11 23:37:37 2016 +0000
+++ b/package.lisp Tue Jul 12 15:46:22 2016 +0000
@@ -13,6 +13,7 @@
#:recursively
#:recur
#:when-let
+ #:symbolize
#:dis
#:megabytes
#:gethash-or-init
--- a/src/utils.lisp Mon Jul 11 23:37:37 2016 +0000
+++ b/src/utils.lisp Tue Jul 12 15:46:22 2016 +0000
@@ -37,6 +37,9 @@
(defun hex (d)
(format nil "~X" d))
+(defun symbolize (&rest args)
+ (intern (format nil "~{~A~}" args)))
+
(defmacro when-let ((symbol value) &body body)
"Bind `value` to `symbol` and execute `body` if the value was not `nil`."
`(let ((,symbol ,value))
--- a/src/wam/bytecode.lisp Mon Jul 11 23:37:37 2016 +0000
+++ b/src/wam/bytecode.lisp Tue Jul 12 15:46:22 2016 +0000
@@ -26,7 +26,9 @@
(#.+opcode-subterm-value-stack+ 2)
(#.+opcode-subterm-void+ 2)
+ (#.+opcode-jump+ 2)
(#.+opcode-call+ 2)
+ (#.+opcode-dynamic-jump+ 1)
(#.+opcode-dynamic-call+ 1)
(#.+opcode-proceed+ 1)
(#.+opcode-allocate+ 2)
@@ -70,7 +72,9 @@
(+opcode-subterm-value-stack+ "SUBTERM-VALUE")
(+opcode-subterm-void+ "SUBTERM-VOID")
+ (+opcode-jump+ "JUMP")
(+opcode-call+ "CALL")
+ (+opcode-dynamic-jump+ "DYNAMIC-JUMP")
(+opcode-dynamic-call+ "DYNAMIC-CALL")
(+opcode-proceed+ "PROCEED")
(+opcode-allocate+ "ALLOCATE")
@@ -111,7 +115,9 @@
(+opcode-subterm-value-stack+ "SVLU")
(+opcode-subterm-void+ "SVOI")
+ (+opcode-jump+ "JUMP")
(+opcode-call+ "CALL")
+ (+opcode-dynamic-jump+ "DYJP")
(+opcode-dynamic-call+ "DYCL")
(+opcode-proceed+ "PROC")
(+opcode-allocate+ "ALOC")
--- a/src/wam/compiler.lisp Mon Jul 11 23:37:37 2016 +0000
+++ b/src/wam/compiler.lisp Tue Jul 12 15:46:22 2016 +0000
@@ -833,10 +833,15 @@
(defclass list-token (register-token) ())
-(defclass call-token (token)
+
+(defclass procedure-call-token ()
((functor :accessor token-functor :type symbol :initarg :functor)
(arity :accessor token-arity :type arity :initarg :arity)))
+(defclass call-token (procedure-call-token) ())
+
+(defclass jump-token (procedure-call-token) ())
+
(defclass cut-token (token) ())
@@ -871,6 +876,12 @@
(token-functor token)
(token-arity token))))
+(defmethod print-object ((token jump-token) stream)
+ (print-unreadable-object (token stream :identity nil :type nil)
+ (format stream "JUMP ~A/~D"
+ (token-functor token)
+ (token-arity token))))
+
(defmethod print-object ((token cut-token) stream)
(print-unreadable-object (token stream :identity nil :type nil)
(format stream "CUT!")))
@@ -911,16 +922,18 @@
(allocate-registers tree clause-props :nead t)
(-> tree flatten-program tokenize-assignments)))
-(defun* tokenize-query-term (term (clause-props clause-properties) &key nead)
+(defun* tokenize-query-term (term
+ (clause-props clause-properties)
+ &key in-nead is-tail)
(:returns list)
"Tokenize `term` as a query term, returning its tokens."
(let ((tree (parse-top-level term)))
- (allocate-registers tree clause-props :nead nead)
+ (allocate-registers tree clause-props :nead in-nead)
(-<> tree
flatten-query
tokenize-assignments
- ;; We need to shove a CALL token onto the end.
- (append <> (list (make-instance 'call-token
+ ;; We need to shove a CALL/JUMP token onto the end.
+ (append <> (list (make-instance (if is-tail 'jump-token 'call-token)
:functor (node-functor tree)
:arity (node-arity tree)))))))
@@ -1121,14 +1134,14 @@
register))
(handle-cut ()
(push-instruction :cut))
- (handle-call (functor arity)
+ (handle-procedure-call (functor arity is-jump)
(if (and (eq functor 'call)
(= arity 1))
- ;; DYNAMIC-CALL
- (push-instruction :dynamic-call)
- ;; CALL functor
+ ;; DYNAMIC-[CALL/JUMP]
+ (push-instruction (if is-jump :dynamic-jump :dynamic-call))
+ ;; [CALL/JUMP] functor
(push-instruction
- :call
+ (if is-jump :jump :call)
(wam-ensure-functor-index wam (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
@@ -1162,9 +1175,14 @@
(handle-list (token-register token)))
(cut-token
(handle-cut))
+ (jump-token
+ (handle-procedure-call (token-functor token)
+ (token-arity token)
+ t))
(call-token
- (handle-call (token-functor token)
- (token-arity token)))
+ (handle-procedure-call (token-functor token)
+ (token-arity token)
+ nil))
(register-token
(handle-register (token-register token)))))
(handle-stream (tokens)
@@ -1194,36 +1212,51 @@
(head-tokens
(when head
(tokenize-program-term head clause-props)))
+ (clause-type
+ (cond ((null head) :query)
+ ((null body) :fact)
+ ((null (rest body)) :chain)
+ (t :rule)))
(body-tokens
(when body
(loop
:with first = t
- :for goal :in body
+ :for (goal . remaining) :on body
:append
- (cond
+ (if (eq goal '!) ; gross
;; cut just gets emitted straight, but DOESN'T flip `first`...
;; TODO: fix the cut layering violation here...
- ((eql goal '!) ; gross
- (list (make-instance 'cut-token)))
- (first
- (setf first nil)
- (tokenize-query-term goal clause-props
- :nead t))
- (t
- (tokenize-query-term goal clause-props)))))))
+ (list (make-instance 'cut-token))
+ (prog1
+ (tokenize-query-term
+ goal clause-props
+ :in-nead first
+ ;; For actual WAM queries we're running, we don't want to
+ ;; LCO the final CALL because we need that stack frame
+ ;; (for storing the results).
+ :is-tail (and (not (eq clause-type :query))
+ (null remaining)))
+ (setf first nil)))))))
(let ((instructions (precompile-tokens wam head-tokens body-tokens))
(variable-count (length (clause-permanent-vars clause-props))))
;; We need to compile facts and rules differently. Facts end with
;; a PROCEED and rules are wrapped in ALOC/DEAL.
- (cond
- ((and head body) ; a full-ass rule
+ (case clause-type
+ ((:chain :rule) ; a full-ass rule
+ ;; Non-chain rules need an ALLOC at the head and a DEALLOC right before
+ ;; the tail call:
+ ;;
+ ;; ALLOC n
+ ;; ...
+ ;; DEAL
+ ;; JUMP
(circle-insert-beginning instructions `(:allocate ,variable-count))
- (circle-insert-end instructions `(:deallocate)))
+ (circle-insert-before (circle-backward instructions) `(:deallocate)))
- ((and head (null body)) ; a bare fact
+ ((:fact)
(circle-insert-end instructions `(:proceed)))
- (t ; a query
+ ((:query)
;; The book doesn't have this ALOC here, but we do it to aid in result
;; extraction. Basically, to make extracting th results of a query
;; easier we allocate all of its variables on the stack, so we need
@@ -1467,7 +1500,9 @@
(:get-list +opcode-get-list+)
(:put-list +opcode-put-list+)
(:subterm-constant +opcode-subterm-constant+)
+ (:jump +opcode-jump+)
(:call +opcode-call+)
+ (:dynamic-jump +opcode-dynamic-jump+)
(:dynamic-call +opcode-dynamic-call+)
(:proceed +opcode-proceed+)
(:allocate +opcode-allocate+)
--- a/src/wam/constants.lisp Mon Jul 11 23:37:37 2016 +0000
+++ b/src/wam/constants.lisp Tue Jul 12 15:46:22 2016 +0000
@@ -1,5 +1,13 @@
(in-package #:bones.wam)
+(defmacro define-constants (count-symbol &rest symbols)
+ `(progn
+ ,@(loop :for c :from 0
+ :for s :in symbols
+ :collect `(define-constant ,s ,c))
+ (define-constant ,count-symbol ,(length symbols))))
+
+
(define-constant +cell-width+ 60
:documentation "Number of bits in each cell.")
@@ -59,7 +67,7 @@
"The maximum number of code words an instruction (including opcode) might be.")
-(define-constant +stack-limit+ 2048
+(define-constant +stack-limit+ 4096
:documentation "Maximum size of the WAM stack.")
(define-constant +stack-frame-size-limit+ (+ 7 +register-count+)
@@ -107,14 +115,7 @@
;;;; Opcodes
-(defmacro define-opcodes (&rest symbols)
- `(progn
- ,@(loop :for c :from 0
- :for s :in symbols
- :collect `(define-constant ,s ,c))
- (define-constant +number-of-opcodes+ ,(length symbols))))
-
-(define-opcodes
+(define-constants +number-of-opcodes+
+opcode-noop+
;; Program
@@ -139,7 +140,9 @@
+opcode-subterm-void+
;; Control
+ +opcode-jump+
+opcode-call+
+ +opcode-dynamic-jump+
+opcode-dynamic-call+
+opcode-proceed+
+opcode-allocate+
--- a/src/wam/dump.lisp Mon Jul 11 23:37:37 2016 +0000
+++ b/src/wam/dump.lisp Tue Jul 12 15:46:22 2016 +0000
@@ -33,14 +33,14 @@
;; This code is awful, sorry.
(let ((store (wam-store wam)))
(format t "HEAP~%")
- (format t " +------+-----+----------+--------------------------------------+~%")
- (format t " | ADDR | TYP | VALUE | DEBUG |~%")
- (format t " +------+-----+----------+--------------------------------------+~%")
+ (format t " +------+-----+------------------+--------------------------------------+~%")
+ (format t " | ADDR | TYP | VALUE | DEBUG |~%")
+ (format t " +------+-----+------------------+--------------------------------------+~%")
(when (> from +heap-start+)
- (format t " | ⋮ | ⋮ | ⋮ | |~%"))
+ (format t " | ⋮ | ⋮ | ⋮ | |~%"))
(flet ((print-cell (i cell indent)
(let ((hi (= i highlight)))
- (format t "~A ~4,'0X | ~A | ~8,'0X | ~36A ~A~%"
+ (format t "~A ~4,'0X | ~A | ~16,'0X | ~36A ~A~%"
(if hi "==>" " |")
i
(cell-type-short-name cell)
@@ -58,16 +58,16 @@
(when (not (zerop indent))
(decf indent))))))
(when (< to (wam-heap-pointer wam))
- (format t " | ⋮ | ⋮ | ⋮ | |~%"))
- (format t " +------+-----+----------+--------------------------------------+~%")
+ (format t " | ⋮ | ⋮ | ⋮ | |~%"))
+ (format t " +------+-----+------------------+--------------------------------------+~%")
(values)))
(defun dump-stack (wam)
(format t "STACK~%")
- (format t " +------+----------+-------------------------------+~%")
- (format t " | ADDR | VALUE | |~%")
- (format t " +------+----------+-------------------------------+~%")
+ (format t " +------+------------------+-------------------------------+~%")
+ (format t " | ADDR | VALUE | |~%")
+ (format t " +------+------------------+-------------------------------+~%")
(with-accessors ((e wam-environment-pointer)
(b wam-backtrack-pointer))
wam
@@ -84,7 +84,7 @@
(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~%"
+ (format t " | ~4,'0X | ~16,'0X | ~30A|~A~A~%"
addr
cell
(case currently-in ; jesus christ this needs to get fixed
@@ -134,7 +134,7 @@
(t ""))
(if (= addr e) " <- E" "")
(if (= addr b) " <- B" "")))))
- (format t " +------+----------+-------------------------------+~%"))
+ (format t " +------+------------------+-------------------------------+~%"))
(defun pretty-functor (functor-index functor-list)
@@ -144,7 +144,7 @@
(format nil "~A/~D" symbol arity))))
(defun pretty-arguments (arguments)
- (format nil "~{ ~4,'0X~}" arguments))
+ (format nil "~10<~{ ~4,'0X~}~;~>" arguments))
(defgeneric instruction-details (opcode arguments functor-list))
@@ -216,10 +216,23 @@
(first arguments)))
(defmethod instruction-details ((opcode (eql +opcode-call+)) arguments functor-list)
- (format nil "CALL~A ; ~A"
+ (format nil "CALL~A ; call ~A"
+ (pretty-arguments arguments)
+ (pretty-functor (first arguments) functor-list)))
+
+(defmethod instruction-details ((opcode (eql +opcode-jump+)) arguments functor-list)
+ (format nil "JUMP~A ; jump ~A"
(pretty-arguments arguments)
(pretty-functor (first arguments) functor-list)))
+(defmethod instruction-details ((opcode (eql +opcode-dynamic-call+)) arguments functor-list)
+ (format nil "DYCL~A ; dynamic call"
+ (pretty-arguments arguments)))
+
+(defmethod instruction-details ((opcode (eql +opcode-dynamic-jump+)) arguments functor-list)
+ (format nil "DYJP~A ; dynamic jump"
+ (pretty-arguments arguments)))
+
(defmethod instruction-details ((opcode (eql +opcode-get-constant+)) arguments functor-list)
(format nil "GCON~A ; X~A = CONSTANT ~A"
(pretty-arguments arguments)
@@ -233,17 +246,17 @@
(pretty-functor (first arguments) functor-list)))
(defmethod instruction-details ((opcode (eql +opcode-subterm-constant+)) arguments functor-list)
- (format nil "SCON~A ; SUBTERM CONSTANT ~A"
+ (format nil "SCON~A ; SUBTERM CONSTANT ~A"
(pretty-arguments arguments)
(pretty-functor (first arguments) functor-list)))
(defmethod instruction-details ((opcode (eql +opcode-get-list+)) arguments functor-list)
- (format nil "GLST~A ; X~A = [vvv | vvv]"
+ (format nil "GLST~A ; X~A = [vvv | vvv]"
(pretty-arguments arguments)
(first arguments)))
(defmethod instruction-details ((opcode (eql +opcode-put-list+)) arguments functor-list)
- (format nil "PLST~A ; X~A = [vvv | vvv]"
+ (format nil "PLST~A ; X~A = [vvv | vvv]"
(pretty-arguments arguments)
(first arguments)))
@@ -261,18 +274,20 @@
(while (< addr to)
(let ((instruction (retrieve-instruction code-store addr)))
(when (>= addr from)
- (let ((lbl (gethash addr lbls))) ; forgive me
- (when lbl
- (format t ";;;; BEGIN ~A~%"
- (pretty-functor lbl (wam-functors wam)))))
- (format t ";~A~4,'0X: "
- (if (= (wam-program-counter wam) addr)
- ">>"
- " ")
- addr)
- (format t "~A~%" (instruction-details (aref instruction 0)
- (rest (coerce instruction 'list))
- (wam-functors wam))))
+ (when (not (= +opcode-noop+ (aref instruction 0)))
+
+ (let ((lbl (gethash addr lbls))) ; forgive me
+ (when lbl
+ (format t ";;;; BEGIN ~A~%"
+ (pretty-functor lbl (wam-functors wam)))))
+ (format t ";~A~4,'0X: "
+ (if (= (wam-program-counter wam) addr)
+ ">>"
+ " ")
+ addr)
+ (format t "~A~%" (instruction-details (aref instruction 0)
+ (rest (coerce instruction 'list))
+ (wam-functors wam)))))
(incf addr (length instruction))))))
(defun dump-code
--- a/src/wam/ui.lisp Mon Jul 11 23:37:37 2016 +0000
+++ b/src/wam/ui.lisp Tue Jul 12 15:46:22 2016 +0000
@@ -167,6 +167,9 @@
(defmacro bytecode (&body body)
`(with-fresh-database
- (push-logic-frame-with ,@body)
- (dump-wam-code *database*)))
+ (push-logic-frame-with ,@body)
+ (format t ";;;; PROGRAM CODE =======================~%")
+ (dump-wam-code *database*)
+ (format t "~%;;;; QUERY CODE =========================~%")
+ (dump-wam-query-code *database*)))
--- a/src/wam/vm.lisp Mon Jul 11 23:37:37 2016 +0000
+++ b/src/wam/vm.lisp Tue Jul 12 15:46:22 2016 +0000
@@ -101,6 +101,7 @@
(if (wam-backtrack-pointer-unset-p wam)
(setf (wam-fail wam) t)
(setf (wam-program-counter wam) (wam-stack-choice-bp wam)
+ (wam-cut-pointer wam) (wam-stack-choice-cc wam)
(wam-backtracked wam) t)))
(defun* trail! ((wam wam) (address store-index))
@@ -474,54 +475,76 @@
;;;; Control Instructions
-(define-instruction (%call)
- ((wam wam)
- (functor functor-index)
- &optional ((program-counter-increment instruction-size)
- (instruction-size +opcode-call+)))
+(declaim (inline %%procedure-call %%dynamic-procedure-call))
+
+
+(defun* %%procedure-call ((wam wam)
+ (functor functor-index)
+ (program-counter-increment instruction-size)
+ (is-tail boolean))
(let ((target (wam-code-label wam functor)))
- (if target
- (setf (wam-continuation-pointer wam) ; CP <- next instruction
- (+ (wam-program-counter wam) program-counter-increment)
+ (if (not target)
+ ;; Trying to call an unknown procedure.
+ (backtrack! wam)
+ (progn
+ (when (not is-tail)
+ (setf (wam-continuation-pointer wam) ; CP <- next instruction
+ (+ (wam-program-counter wam) program-counter-increment)))
+ (setf (wam-number-of-arguments wam) ; set NARGS
+ (wam-functor-arity wam functor)
+
+ (wam-cut-pointer wam) ; set B0 in case we have a cut
+ (wam-backtrack-pointer wam)
+
+ (wam-program-counter wam) ; jump
+ target)))))
- (wam-number-of-arguments wam) ; set NARGS
- (wam-functor-arity wam functor)
+(defun* %%dynamic-procedure-call ((wam wam) (is-tail boolean))
+ (flet ((%go (functor)
+ (if is-tail
+ (%%procedure-call
+ wam functor (instruction-size +opcode-dynamic-jump+) t)
+ (%%procedure-call
+ wam functor (instruction-size +opcode-dynamic-call+) nil))))
+ (with-cell (addr cell) wam 0 ; A_0
+ (cond
+ ((cell-structure-p cell)
+ (with-cell (functor-address functor-cell) wam (cell-value cell)
+ (let ((functor (cell-value functor-cell)))
+ ;; If we have a non-zero-arity structure, we need to set up the
+ ;; argument registers before we call it. Luckily all the arguments
+ ;; conveniently live contiguously right after the functor cell.
+ (loop :with arity = (wam-functor-arity wam functor)
+ :for argument-register :from 0 :below arity
+ :for argument-address :from (1+ functor-address)
+ :do (setf (wam-local-register wam argument-register)
+ (wam-heap-cell wam argument-address)))
+ (%go functor))))
+ ((cell-constant-p cell)
+ ;; Zero-arity functors don't need to set up anything at all -- we can
+ ;; just call them immediately.
+ (%go (cell-value cell)))
+ ((cell-reference-p cell)
+ ;; It's okay to do (call :var), but :var has to be bound by the time you
+ ;; actually reach it at runtime.
+ (error "Cannot dynamically call an unbound variable."))
+ (t ; You can't (call) anything else.
+ (error "Cannot dynamically call something other than a structure."))))))
- (wam-cut-pointer wam) ; set B0 in case we have a cut
- (wam-backtrack-pointer wam)
+
+(define-instruction (%jump) ((wam wam) (functor functor-index))
+ (%%procedure-call wam functor (instruction-size +opcode-jump+) t))
- (wam-program-counter wam) ; jump
- target)
- ;; Trying to call an unknown procedure.
- (backtrack! wam))))
+(define-instruction (%call) ((wam wam) (functor functor-index))
+ (%%procedure-call wam functor (instruction-size +opcode-call+) nil))
+
(define-instruction (%dynamic-call) ((wam wam))
- ;; It's assumed that whatever we want to dynamically call has been put in
- ;; argument register zero.
- (with-cell (addr cell) wam 0 ; A_0
- (cond
- ((cell-structure-p cell)
- (with-cell (functor-address functor-cell) wam (cell-value cell)
- (let ((functor (cell-value functor-cell)))
- ;; If we have a non-zero-arity structure, we need to set up the
- ;; argument registers before we call it. Luckily all the arguments
- ;; conveniently live contiguously right after the functor cell.
- (loop :with arity = (wam-functor-arity wam functor)
- :for argument-register :from 0 :below arity
- :for argument-address :from (1+ functor-address)
- :do (setf (wam-local-register wam argument-register)
- (wam-heap-cell wam argument-address)))
- (%call wam functor (instruction-size +opcode-dynamic-call+)))))
- ((cell-constant-p cell)
- ;; Zero-arity functors don't need to set up anything at all -- we can
- ;; just call them immediately.
- (%call wam (cell-value cell) (instruction-size +opcode-dynamic-call+)))
- ((cell-reference-p cell)
- ;; It's okay to do (call :var), but :var has to be bound by the time you
- ;; actually reach it at runtime.
- (error "Cannot dynamically call an unbound variable."))
- (t ; You can't (call) anything else.
- (error "Cannot dynamically call something other than a structure.")))))
+ (%%dynamic-procedure-call wam nil))
+
+(define-instruction (%dynamic-jump) ((wam wam))
+ (%%dynamic-procedure-call wam t))
+
(define-instruction (%proceed t) ((wam wam))
(setf (wam-program-counter wam) ; P <- CP
@@ -538,7 +561,7 @@
(wam-environment-pointer wam) new-e))) ; E <- new-e
(define-instruction (%deallocate) ((wam wam))
- (setf (wam-program-counter wam) (wam-stack-frame-cp wam)
+ (setf (wam-continuation-pointer wam) (wam-stack-frame-cp wam)
(wam-environment-pointer wam) (wam-stack-frame-ce wam)
(wam-cut-pointer wam) (wam-stack-frame-cut wam)))
@@ -546,6 +569,7 @@
;;;; Choice Instructions
(declaim (inline reset-choice-point!))
+
(defun* reset-choice-point! ((wam wam)
(b backtrack-pointer))
(setf (wam-backtrack-pointer wam) b
@@ -565,10 +589,11 @@
+heap-start+
(wam-stack-choice-h wam b))))
+
(define-instruction (%try) ((wam wam) (next-clause code-index))
(let ((new-b (wam-stack-top wam))
(nargs (wam-number-of-arguments wam)))
- (wam-stack-ensure-size wam (+ new-b 7 nargs))
+ (wam-stack-ensure-size wam (+ new-b 8 nargs))
(setf (wam-stack-word wam new-b) nargs ; N
(wam-stack-word wam (+ new-b 1)) (wam-environment-pointer wam) ; CE
(wam-stack-word wam (+ new-b 2)) (wam-continuation-pointer wam) ; CP
@@ -576,6 +601,7 @@
(wam-stack-word wam (+ new-b 4)) next-clause ; BP
(wam-stack-word wam (+ new-b 5)) (wam-trail-pointer wam) ; TR
(wam-stack-word wam (+ new-b 6)) (wam-heap-pointer wam) ; H
+ (wam-stack-word wam (+ new-b 7)) (wam-cut-pointer wam) ; CC
(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
@@ -622,6 +648,7 @@
;;;; Constant Instructions
(declaim (inline %%match-constant))
+
(defun* %%match-constant ((wam wam)
(constant functor-index)
(address store-index))
@@ -639,6 +666,7 @@
(t
(backtrack! wam)))))
+
(define-instruction (%put-constant t)
((wam wam)
(constant functor-index)
@@ -770,24 +798,28 @@
(#.+opcode-cut+ (instruction %cut 0))
;; Control
(#.+opcode-allocate+ (instruction %allocate 1))
- ;; need to skip the PC increment for PROC/CALL/DEAL/DONE
- ;; TODO: this is still ugly
- (#.+opcode-deallocate+
- (instruction %deallocate 0)
- (setf increment-pc nil))
+ (#.+opcode-deallocate+ (instruction %deallocate 0))
+ ;; need to skip the PC increment for PROC/CALL/JUMP/DONE
+ ;; TODO: this is (still) still ugly
(#.+opcode-proceed+
- (instruction %proceed 0)
- (setf increment-pc nil))
+ (instruction %proceed 0)
+ (setf increment-pc nil))
+ (#.+opcode-jump+
+ (instruction %jump 1)
+ (setf increment-pc nil))
(#.+opcode-call+
- (instruction %call 1)
- (setf increment-pc nil))
+ (instruction %call 1)
+ (setf increment-pc nil))
+ (#.+opcode-dynamic-jump+
+ (instruction %dynamic-jump 0)
+ (setf increment-pc nil))
(#.+opcode-dynamic-call+
- (instruction %dynamic-call 0)
- (setf increment-pc nil))
+ (instruction %dynamic-call 0)
+ (setf increment-pc nil))
(#.+opcode-done+
- (if (funcall done-thunk)
- (return-from run)
- (backtrack! wam))))
+ (if (funcall done-thunk)
+ (return-from run)
+ (backtrack! wam))))
;; Only increment the PC when we didn't backtrack.
;;
;; If we backtracked, the PC will have been filled in from the
--- a/src/wam/wam.lisp Mon Jul 11 23:37:37 2016 +0000
+++ b/src/wam/wam.lisp Tue Jul 12 15:46:22 2016 +0000
@@ -390,22 +390,27 @@
;;; Choice point frames are laid out like so:
;;;
;;; |PREV|
-;;; 0 | N | <-- backtrack-pointer
-;;; 1 | CE |
-;;; 2 | CP | This is a bit different than the book. We stick the
-;;; 3 | CB | arguments at the end of the frame instead of the beginning,
-;;; 4 | BP | so it's easier to retrieve the other values.
-;;; 5 | TR |
-;;; 6 | H |
-;;; 7 | A0 |
+;;; 0 | N | number of arguments <-- backtrack-pointer
+;;; 1 | CE | continuation environment
+;;; 2 | CP | continuation pointer
+;;; 3 | CB | previous choice point
+;;; 4 | BP | next clause
+;;; 5 | TR | trail pointer
+;;; 6 | H | heap pointer
+;;; 7 | CC | saved cut pointer
+;;; 8 | A0 |
;;; | .. |
-;;; 7+n | An |
-;;; |NEXT| <-- fill-pointer
+;;; 8+n | An |
+;;; |NEXT| <-- environment-pointer
+;;;
+;;; This is a bit different than the book. We stick the args at the end of the
+;;; frame instead of the beginning so it's easier to retrieve the other values.
(declaim (inline wam-stack-choice-n
wam-stack-choice-ce
wam-stack-choice-cp
wam-stack-choice-cb
+ wam-stack-choice-cc
wam-stack-choice-bp
wam-stack-choice-tr
wam-stack-choice-h
@@ -469,6 +474,14 @@
(:returns heap-index)
(wam-stack-word wam (+ b 6)))
+(defun* wam-stack-choice-cc
+ ((wam wam)
+ &optional
+ ((b backtrack-pointer)
+ (wam-backtrack-pointer wam)))
+ (:returns backtrack-pointer)
+ (wam-stack-word wam (+ b 7)))
+
(defun* wam-stack-choice-arg
((wam wam)
@@ -477,14 +490,14 @@
((b backtrack-pointer)
(wam-backtrack-pointer wam)))
(:returns cell)
- (wam-stack-word wam (+ b 7 n)))
+ (wam-stack-word wam (+ b 8 n)))
(defun* (setf wam-stack-choice-arg) ((new-value cell)
(wam wam)
(n arity)
&optional ((b backtrack-pointer)
(wam-backtrack-pointer wam)))
- (setf (wam-stack-word wam (+ b 7 n))
+ (setf (wam-stack-word wam (+ b 8 n))
new-value))
@@ -495,7 +508,7 @@
(wam-backtrack-pointer wam)))
(:returns stack-choice-size)
"Return the size of the choice frame starting at backtrack pointer `b`."
- (+ (wam-stack-choice-n wam b) 7))
+ (+ (wam-stack-choice-n wam b) 8))
(defun* wam-stack-top ((wam wam))
@@ -531,8 +544,7 @@
(setf (fill-pointer (wam-unification-stack wam)) 0))
(defun* wam-reset-local-registers! ((wam wam))
- (loop :for i :from 0 :below +register-count+ :do
- (setf (wam-local-register wam i) (make-cell-null))))
+ (fill (wam-store wam) (make-cell-null) :start 0 :end +register-count+))
(defun* wam-reset! ((wam wam))
(wam-truncate-heap! wam)
--- a/test/wam.lisp Mon Jul 11 23:37:37 2016 +0000
+++ b/test/wam.lisp Tue Jul 12 15:46:22 2016 +0000
@@ -448,3 +448,31 @@
(is (not (string= ""
(with-output-to-string (*standard-output*)
(dump-wam-full *test-database*))))))
+
+(test last-call-optimization
+ (let* ((big-ass-list (loop :repeat 1000 :collect 'a))
+ (big-ass-result (reverse (cons 'x big-ass-list))))
+ (with-fresh-database
+ (push-logic-frame-with
+ (invoke-fact `(big-ass-list (list ,@big-ass-list)))
+
+ (fact (append nil ?l ?l))
+ (rule (append (list* ?i ?tail) ?other (list* ?i ?l))
+ (append ?tail ?other ?l)))
+
+ (is (results= `((?bal ,big-ass-list ?bar ,big-ass-result))
+ (query-all (big-ass-list ?bal)
+ (append ?bal (list x) ?bar)))))))
+
+; (test hanoi
+; (with-fresh-database
+; (push-logic-frame-with
+; (fact (append nil ?l ?l))
+; (rule (append (list* ?i ?tail) ?other (list* ?i ?l))
+; (append ?tail ?other ?l))
+
+; (fact (hanoi zero ?a ?b ?c (list (move ?a ?b))))
+; (rule (hanoi (s ?n) ?a ?b ?c ?moves)
+; (hanoi ?n ?a ?c ?b ?moves1)
+; (hanoi ?n ?c ?b ?a ?moves2)
+; (append ?moves1 (list* (move ?a ?b) ?moves2) ?moves)))))