# HG changeset patch
# User Steve Losh <steve@stevelosh.com>
# Date 1472918296 0
# Node ID 7d1e30b7233c8dd80947420d46f0ebc67093d13b
# Parent  11228bf838d0793c449617a051c2b764b334dc35
Add rudimentary tracing support

diff -r 11228bf838d0 -r 7d1e30b7233c src/ui.lisp
--- a/src/ui.lisp	Sat Sep 03 14:44:49 2016 +0000
+++ b/src/ui.lisp	Sat Sep 03 15:58:16 2016 +0000
@@ -240,3 +240,12 @@
     (format t "~%;;;; QUERY CODE =========================~%")
     (dump-wam-query-code *standard-database*)))
 
+(defmacro trace-predicate (functor)
+  `(pushnew ',functor *trace*))
+
+(defmacro untrace-predicate (functor)
+  `(setf *trace* (remove ',functor *trace*)))
+
+(defun untrace-all ()
+  (setf *trace* nil))
+
diff -r 11228bf838d0 -r 7d1e30b7233c src/vm.lisp
--- a/src/vm.lisp	Sat Sep 03 14:44:49 2016 +0000
+++ b/src/vm.lisp	Sat Sep 03 15:58:16 2016 +0000
@@ -2,6 +2,7 @@
 
 ;;;; Config
 (defvar *step* nil)
+(defvar *trace* nil)
 
 
 ;;;; Utilities
@@ -462,12 +463,21 @@
 (declaim (inline %%procedure-call %%dynamic-procedure-call))
 
 
+(defun dump-trace (wam functor arity)
+  (format t "; => (~A/~D ~{~S~^ ~})~%" functor arity
+          (extract-things wam (loop :for i :from 0 :below arity :collect i)))
+  (finish-output))
+
 (defun %%procedure-call (wam functor arity program-counter-increment is-tail)
   (let* ((target (wam-code-label wam functor arity)))
     (if (not target)
       ;; Trying to call an unknown procedure.
       (backtrack! wam)
       (progn
+        (policy-cond:policy-if (or (> debug 0) (< speed 3))
+          (when (member functor *trace*)
+            (dump-trace wam functor arity))
+          nil)
         (when (not is-tail)
           (setf (wam-continuation-pointer wam) ; CP <- next instruction
                 (+ (wam-program-counter wam) program-counter-increment)))