2ce458ef85fd

Implement last call optimization
[view raw] [browse files]
author Steve Losh <steve@stevelosh.com>
date Tue, 12 Jul 2016 15:46:22 +0000
parents cb3cc671d18d
children df9962950d28
branches/tags (none)
files package-test.lisp package.lisp src/utils.lisp src/wam/bytecode.lisp src/wam/compiler.lisp src/wam/constants.lisp src/wam/dump.lisp src/wam/ui.lisp src/wam/vm.lisp src/wam/wam.lisp test/wam.lisp

Changes

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