# HG changeset patch # User Steve Losh # Date 1468338382 0 # Node ID 2ce458ef85fdfd36964611883b349bc33b809523 # Parent cb3cc671d18dba55acb8de81a4beb81ca4c40d3e Implement last call optimization diff -r cb3cc671d18d -r 2ce458ef85fd package-test.lisp --- 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 #:!)) diff -r cb3cc671d18d -r 2ce458ef85fd package.lisp --- 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 diff -r cb3cc671d18d -r 2ce458ef85fd src/utils.lisp --- 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)) diff -r cb3cc671d18d -r 2ce458ef85fd src/wam/bytecode.lisp --- 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") diff -r cb3cc671d18d -r 2ce458ef85fd src/wam/compiler.lisp --- 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+) diff -r cb3cc671d18d -r 2ce458ef85fd src/wam/constants.lisp --- 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+ diff -r cb3cc671d18d -r 2ce458ef85fd src/wam/dump.lisp --- 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 diff -r cb3cc671d18d -r 2ce458ef85fd src/wam/ui.lisp --- 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*))) diff -r cb3cc671d18d -r 2ce458ef85fd src/wam/vm.lisp --- 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 diff -r cb3cc671d18d -r 2ce458ef85fd src/wam/wam.lisp --- 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) diff -r cb3cc671d18d -r 2ce458ef85fd test/wam.lisp --- 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)))))