matsud224/wamcompiler

Prolog implementation based on Warren's abstract machine

README

This is a prolog compiler written in Common Lisp which compiles prolog code to bytecode of Warren's abstract machine (WAM).

I recommend using Steel Bank Common Lisp (SBCL). To start REPL, eval the following expression:

(load "wamcompiler.lisp")
(repl)

Input ';' to show the next solution, 'y' to stop finding solutions, or 'a' to show all solutions.

To show the compiled bytecode, eval the following expression:

(show-wamcode "predicate-name" predicate-arity)

An article of this program (in Japanese): 「すごいPrologつくって学ぼう?!」 pp.23-37 http://www.kitcc.org/share/lime/lime56.pdf

References

• AN ABSTRACT PROLOG INSTRUCTION SET (Japanese translation) http://www.takeoka.org/~take/ailabo/prolog/wam/wam.html

  • Original: http://www.ai.sri.com/pubs/files/641.pdf

• Warren's Abstract Machine: A Tutorial Reconstruction http://wambook.sourceforge.net/

wamcompiler's Issues

Great work, but ...

Wamcompiler is a very impressive piece of software. As far as I know, it is the first decent implementation of Prolog in Common Lisp. Many people tried and failed in this endeavor. For instance, Paul Graham, Peter Norvig, Mauro Jacob and Patrice Boizumalt were not able to implement Prolog in Lisp. You did it and deserve the credit and praise for a great work. However, there is a small bug in your implementation. I hope that you fix it as soon as possible, so that my students can start using your Prolog. Let us see an example of the problem:

~/wrkLisp/src/wamcompiler master •
› rlwrap ros run
* (load "wamcompiler.lisp")
* (repl)
> gn(N, 42) :- N =< 4, write(small), nl.
> gn(N, 43) :- N > 4, write(large), nl.
> ?- gn(2, Res).
small
Res = 42
?;

no.
> ?- gn(8, Res).
large
Res = 43

yes.

%% So far, so good. That is exactly what I was expecting.
%% Now, let us add a cut to the first clause:

> fn(N, 42) :- N =< 4, ! , write(small), nl.
> fn(N, 43) :- N > 4, write(large), nl.
> ?- fn(2, G).

It does not work. I believe that the problem lies in the cut. I have a few other suggestion for your consideration, after fixing the bug, of course.

Suggestion 1: Add prototypes in order to avoid warnings. Here are the prototypes that you should add at the beginning of the wamcompiler.lisp file:

(declaim (ftype (function (t) t) set-to-trail))
(declaim (ftype (function (t) t) send-query))
(declaim (ftype (function (t) t) prolog-expr->string))
(declaim (ftype (function (t &optional t) t) compile-clause))
(declaim (ftype (function (t) t) divide-head-body))
(declaim (ftype (function (t t) t) optimize-wamcode))
(declaim (ftype (function (t) t) skip-comment))
(declaim (ftype (function (t) t) skip-whitespace))
(declaim (ftype (function (t) t) read-non-alphanum-atom))
(declaim (ftype (function (t) t) read-num))
(declaim (ftype (function (t) t) read-quoted-atom))
(declaim (ftype (function (t) t) read-alphanum-atom))
(declaim (optimize (speed 3) (space 0) (debug 0) (safety 0)))

Suggestion 2: Add general numeric operations. For instance, you can replace read-int with read-num, as shown below:

(defun get-token (s)
  (skip-whitespace s)
  (let ((c (read-char s)))
    (cond ((null c) nil)
	  ((eq c #\%) (skip-comment s) (get-token s))
	  ((eq c #\)) '(rparen))
	  ((eq c #\() '(lparen))
	  ((eq c #\]) '(rbracket))
	  ((eq c #\[) '(lbracket))
	  ((eq c #\|) '(vertical-bar))
	  ((eq c #\,) (cons 'atom '|,|))
	  ((eq c #\;) (cons 'atom '|;|))
	  ((eq c #\!) (cons 'atom '|!|))
	  ((eq c #\') (read-quoted-atom s))
	  ((digit-char-p c) (unread-char c s) (cons 'atom (read-num s) ))
	  ((member c *non-alphanum-chars*)
	   (unread-char c s) (read-non-alphanum-atom s))
	  (t (unread-char c s) (read-alphanum-atom s)))))

;;; ... stuff

(defun read-num (s)
  (let* ( (acc)
	  (point t))
    (dostream (c s)
	      (unless (or (digit-char-p c)
			  (and point (equal #\. c)))
		(unread-char c s) (return nil))
	      (setq acc (cons c acc))
	      (when (equal c #\.) (setq point nil)))
    (cond ( (equal (car acc) #\.) (unread-char (car acc) s)
	      (parse-integer (concatenate 'string (reverse (cdr acc))) ))
	  (point (parse-integer (concatenate 'string (reverse acc)) ))
	  (t (parse-string-to-float
	      (concatenate 'string (reverse acc))) ))))

Suggestion 3: Add a few optimizations, which can boost speed by 50% at least. For instance, just by adding a declaration of type to a few definitions, I was able to boost speed by 40 percent. Here is an example:

(defun heap (addr)
  (declare (optimize (speed 3) (space 0) (debug 0) (safety 0))
	   (type fixnum addr))
  (aref *heap-area* (1- (- (/ addr 2)))))

My experience shows that one can obtain huge improvements by using arrays of numbers, instead of general Lisp symbolic expressions. I wonder if you could replace at least one of the prolog stacks with a numerical stack. I did this in the Boizumalt Prolog, and it bacame three times faster.

Hunting bugs

I tried to create simple instances of the bug I found in wamcompiler. In fact, I can reproduce the bugs from the repl. Besides, I found another bug in the repl itself.

Bug 1 -- This is quite easy to fix, I believe.

~/wambugs/wamcompiler master •
› rlwrap ros run
* (load "wamcompiler.lisp")
* (repl)
> ?- !, write(passed), nl.

debugger invoked on a TYPE-ERROR in thread
#<THREAD "main thread" RUNNING {10005184C3}>:
  The value
    NIL
  is not of type
    NUMBER
  when binding SB-KERNEL::X

To fix this bug, I believe that one should go to the send-query definition and fix the neck-cut snippet as shown below:

	   (neck-cut (when  (and *B* *B0* (addr< *B0* *B*))
			       (setq *B* *B0*)
			       (tidy-trail))
			     (setq *P* (cdr *P*))) 

Bug 2 -- This one is tough for a person who is not familiar with the wam. By the way, I think that you had it right, since you added the definition of the takai predicate into prelude.pl. Since the takai predicate does not work because of this bug, I believe that wamcompiler was correct when you tested the prelude. Any way, here is a simple test for bug 2:

* (repl)
> ?- X is 42, X < 50, write(passed), nl.
passed
X = 42

yes.
> ?- X is 42, X < 50, !, write(passed), nl.

Anatomy of the remaining bug

I discovered that the bug appears whenever one places the cut after an arithmetic expression or unification. In these two situations, instead of obtaining a number from the stack, the cut returns something like a (REF . -23) or (CON . 1). The problem happens at the send-query definition, when the case clause pass the control to the snippet below.

  (cut (let ( (y (cadr inst)) )
			  (when (and *B* *E*
				     (addr< (stack (addr+ *E* 2 y)) *B*))
			    (setf *B* (stack (addr+ *E* 2 y)))
			    (tidy-trail))
			  (setq *P* (cdr *P*))))

Consider the following small Prolog program:

› cat ybug.pl
qua(N, F) :- N < 5, F is N + 1, !.

que(N, F) :- F is N + 1, N < 5, !.

qui(N, 3) :- N < 5, !.

The snippet qui works fine:

> ?- qui(2, F).
F = 3

yes.

However, when I try to execute qua(1, F), the application (stack (addr+ E 2 y)) produces (REF . -23), which is not a number. In consequence, I get the following error:

debugger invoked on a TYPE-ERROR in thread
#<THREAD "main thread" RUNNING {10005184C3}>:
  The value
    (REF . -23)
  is not of type
    NUMBER
  when binding SB-KERNEL::X

If I execute que(1, F), the application (stack (addr E 2 y)) produces (CON . 1) instead of a number. I examined the generated code in the two situations:

* (gethash (cons '|qua| 2) *dispatching-code-table*)
((ALLOCATE) (GET-LEVEL 1) (GET-VARIABLE-PERMANENT 3 1)
 (GET-VARIABLE-PERMANENT 2 2) (PUT-CONSTANT 5 2)
(CALL (< . 2) 3)  (PUT-UNSAFE-VALUE 2 1 3)
(PUT-STRUCTURE (+ . 2) 2)  (SET-LOCAL-VALUE-PERMANENT 3)
(SET-CONSTANT 1) (CALL (|is| . 2) 1) (CUT 1 1)
 (DEALLOCATE) (PROCEED))
T

As you can see, the bug occurs when (CUT 1 1) appears after a (PUT-UNSAFE-VALUE ...) in a clause. I wonder whether it is possible to dereference the value (RED . -23), in order to find the true index. If you don't have a solution, my suggestion is to disallow cuts after (PUT-UNSAFE-VALUE ...). This will be very easy to do, however, it would be nice not to take such a radical course of action.

By the way, I compared wamcompiler with Scryer Prolog, which is written in Rust. Wamcompiler is faster. I think that wamcompiler can be made even faster, if one replaces part of the wamcode by Lisp functions that execute a sequence of many instructions.

I am preparing a documentation for wamcompiler. I wrote a book about Visual Prolog, and I think I can easily adapt it to wamcompiler.

Temporary fix for bug

I placed a temporary fix for the neck-cut bug. I will not make a Pull request because I myself am not satisfied with the solution. It works, but is not very elegant. In any case, after the patch, I was able to solve Werner Hett's Ninety-Nine Prolog problems from 1 to 35. I used the numeration that appears at the page of UNICAMP, not Hett's. It seems that my awkward and coarse patch did not impaired the speed of wamcompiler. You will find wamcompiler with the patch and the Ninety-Nine Prolog problems here at the Femto Emacs fork of your repository:

https://github.com/FemtoEmacs/wamcompiler

You need to download three files for testing the Ninety-Nine Prolog problems, to wit:

1. rnd.lisp -- this file contains a random number generator and need to be load before executing (repl)
2. p99.pl -- that contains 35 problems from Hett's collection
3. wamcompiler with the patch

In a nutshell, the patch introduces a `true` predicate in front of the cut, in case of neck-cut. Thus, the neck-cut becomes a normal cut.

```lisp
(defun add-true(s)
  (if (and (consp s) (equal (car s) '(|!|)) ) (cons '(|true|) s) s))

(defun divide-head-body (clause)
  (destructuring-bind
	(head body clause-type)
        (cond
            ( (and (eq (car clause) '|:-|) (= (arity clause) 2))
               (list (cadr clause) 
                     (add-true (flatten-comma (caddr clause))) 'rule))
;;; ... etc

(define-prolog-builtin "true" ()
  (let  ((wam-code '((proceed))))
    (setf *P* wam-code)))

Bug in neck-cut remains

The bug in neck-cut remains. To test wamcompiler, I am using Werner Hett's P-99: Ninety-Nine Prolog Programs. Here are two examples where wamcompiler produces a bug (the triple %%% commented version avoids neck-cut and work):

% P09 (**):  Pack consecutive duplicates of list elements.
%% > ?-pack([2,3,3,3,4,4,5], L).
%% L = [[2],[3,3,3],[4,4],[5]]
%% bugneck-cut

pack([],[]) :- !.
pack([X|Xs],[Z|Zs]) :- transfer(X,Xs,Ys,Z), pack(Ys,Zs).

% transfer(X,Xs,Ys,Z) Ys is the list that remains from the list Xs
%    when all leading copies of X are removed and transfered to Z

transfer(X,[],[],[X]) :- !.
transfer(X,[X|Xs],Ys,[X|Zs]) :- !, transfer(X,Xs,Ys,Zs).
%%% transfer(Y,[X|Xs],Ys,[X|Zs]) :- Y == X, !, transfer(X,Xs,Ys,Zs).
transfer(X,[Y|Ys],[Y|Ys],[X]).

% P11 (*):  Modified run-length encoding
%% > ?-encode_modified([1,1,2,2,2,2,2,3,3,4], G).
%% G = [[2,1],[5,2],[2,3],4]
%% bugneckcut
encode_modified(L1,L2) :- encode(L1,L), strip(L,L2).

strip([],[]) :- !.
strip([[1,X]|Ys],[X|Zs]) :-  !, strip(Ys,Zs).
strip([[N,X]|Ys],[[N,X]|Zs]) :- N > 1, strip(Ys,Zs).

% P15 (**): Duplicate the elements of a list agiven number of times
%% > ?-dupli([1,2,2,3,3,3,5], 4,  L).
%% L = [1,1,1,1,2,2,2,2,2,2,2,2,3,3,3,3,3,3,3,3,3,3,3,3,5,5,5,5]
%% bugneckcut
dupli(L1,N,L2) :- dupli(L1,N,L2,N).

dupli([],_,[],_) :- !.
dupli([_|Xs],N,Ys, 0) :- !, dupli(Xs,N,Ys,N).
%%%dupli([_|Xs],N,Ys, K) :- K == 1, !, dupli(Xs,N,Ys,N).
dupli([X|Xs],N,[X|Ys],K) :- K > 0, K1 is K - 1,
                dupli([X|Xs],N,Ys,K1).