Rewrite the compiler
A few days ago I found a bug in the compiler that I decided merited basically an
entire rewrite of it.
This was long overdue. The compiler kind of grew organically and unhealthily
over time as I wrapped my head around how the whole WAM is structured, and now
that I understand a lot more I can do things right.
This new implementation is a lot "flatter" than the old one. It makes use of
CLOS classes and generic methods to un-nest a lot of the crap that was
previously happening in bigass `labels` blocks. This is a lot easier to read
and understand because you can take things a piece at a time.
Unfortunately, it's currently a lot slower than the old one. But at least it's
*correct*, and now I can start taking a look at optimizing the performance with
a cleaner base to start from.
Notes/ideas for the near future:
* Switch to structs instead of CLOS classes for all the bits and bobs in the
compilation process.
* Inline hot functions in the compilation process.
* Type hint the fucking compiler already. I've put this off for far too long.
* Move the compiler to its own package for easier profiling and to maintain my
shreds of sanity.
* Look into that generic-function-inlining library thing I saw on Reddit...
* Remove the last vestiges of `match` and kill the dependency on optima.
| author |
Steve Losh <steve@stevelosh.com> |
| date |
Tue, 07 Jun 2016 14:49:20 +0000 |
| parents |
e244881864f7 |
| children |
809f43baf982 |
(in-package #:bones-test.wam)
(def-suite :bones.wam)
(in-suite :bones.wam)
;;;; Setup
(defun make-test-database ()
(let ((db (make-database)))
(with-database db
(facts (always))
(facts (drinks tom :anything)
(drinks kim water)
(drinks alice bourbon)
(drinks bob genny-cream)
(drinks candace birch-beer))
(facts (listens alice blues)
(listens alice jazz)
(listens bob blues)
(listens bob rock)
(listens candace blues))
(facts (fuzzy cats))
(facts (cute cats)
(cute snakes))
(rules ((pets alice :what)
(cute :what))
((pets bob :what)
(cute :what)
(fuzzy :what))
((pets candace :bird)
(flies :bird)))
(rules ((likes sally :who)
(likes :who cats)
(drinks :who beer))
((likes tom cats))
((likes alice cats))
((likes kim cats))
((likes kim :who)
(likes :who cats)))
(rules ((narcissist :person)
(likes :person :person)))
(rules ((member :x (list* :x :rest)))
((member :x (list* :y :rest))
(member :x :rest))))
db))
(defparameter *test-database* (make-test-database))
;;;; Utils
(defun result= (x y)
(set-equal (plist-alist x)
(plist-alist y)
:test #'equal))
(defun results= (r1 r2)
(set-equal r1 r2 :test #'result=))
(defmacro q (&body query)
`(return-all ,@query))
(defmacro should-fail (&body queries)
`(progn
,@(loop :for query :in queries :collect
`(is (results= nil (q ,query))))))
(defmacro should-return (&body queries)
`(progn
,@(loop :for (query results) :in queries :collect
`(is (results= ',results (q ,query))))))
;;;; Tests
(test facts-literal
(with-database *test-database*
(is (results= '(nil) (q (always))))
(is (results= '(nil) (q (fuzzy cats))))
(is (results= nil (q (fuzzy snakes))))))
(test facts-variables
(with-database *test-database*
(is (results= '((:what cats))
(q (fuzzy :what))))
(is (results= '((:what blues)
(:what rock))
(q (listens bob :what))))
(is (results= '((:who alice)
(:who bob)
(:who candace))
(q (listens :who blues))))
(is (results= '()
(q (listens :who metal))))))
(test facts-conjunctions
(with-database *test-database*
(is (results= '((:who alice))
(q (listens :who blues)
(listens :who jazz))))
(is (results= '((:who alice))
(q (listens :who blues)
(drinks :who bourbon))))
(is (results= '((:what bourbon :who alice)
(:what genny-cream :who bob)
(:what birch-beer :who candace))
(q (listens :who blues)
(drinks :who :what))))))
(test backtracking
(with-fresh-database
(facts (a))
(facts (b))
(facts (c))
(facts (d))
(rules ((f :x) (a))
((f :x) (b) (c))
((f :x) (d)))
(should-return
((f foo)
(nil))))
(with-fresh-database
; (facts (a))
(facts (b))
(facts (c))
(facts (d))
(rules ((f :x) (a))
((f :x) (b) (c))
((f :x) (d)))
(should-return
((f foo)
(nil))))
(with-fresh-database
; (facts (a))
(facts (b))
(facts (c))
; (facts (d))
(rules ((f :x) (a))
((f :x) (b) (c))
((f :x) (d)))
(should-return
((f foo)
(nil))))
(with-fresh-database
; (facts (a))
; (facts (b))
(facts (c))
; (facts (d))
(rules ((f :x) (a))
((f :x) (b) (c))
((f :x) (d)))
(should-return
((f foo)
nil)))
(with-fresh-database
; (facts (a))
(facts (b))
; (facts (c))
; (facts (d))
(rules ((f :x) (a))
((f :x) (b) (c))
((f :x) (d)))
(should-return
((f foo)
nil))))
(test basic-rules
(with-database *test-database*
(should-fail
(pets candace :what))
(should-return
((pets alice :what)
((:what snakes) (:what cats)))
((pets bob :what)
((:what cats)))
((pets :who snakes)
((:who alice)))
((likes kim :who)
((:who tom)
(:who alice)
(:who kim)
(:who cats)))
((likes sally :who)
((:who tom)))
((narcissist :person)
((:person kim))))))
(test lists
(with-database *test-database*
(should-fail
(member :anything nil)
(member a nil)
(member b (list a))
(member (list a) (list a))
(member a (list (list a))))
(should-return
((member :m (list a))
((:m a)))
((member :m (list a b))
((:m a) (:m b)))
((member :m (list a b a))
((:m a) (:m b)))
((member a (list a))
(nil))
((member (list foo) (list a (list foo) b))
(nil)))))
(test cut
(with-fresh-database
(facts (a))
(facts (b))
(facts (c))
(facts (d))
(rules ((f a) (a))
((f bc) (b) ! (c))
((f d) (d)))
(rules ((g :what) (never))
((g :what) (f :what)))
(should-return
((f :what) ((:what a)
(:what bc)))
((g :what) ((:what a)
(:what bc)))))
(with-fresh-database
; (facts (a))
(facts (b))
(facts (c))
(facts (d))
(rules ((f a) (a))
((f bc) (b) ! (c))
((f d) (d)))
(rules ((g :what) (never))
((g :what) (f :what)))
(should-return
((f :what) ((:what bc)))
((g :what) ((:what bc)))))
(with-fresh-database
; (facts (a))
; (facts (b))
(facts (c))
(facts (d))
(rules ((f a) (a))
((f bc) (b) ! (c))
((f d) (d)))
(rules ((g :what) (never))
((g :what) (f :what)))
(should-return
((f :what) ((:what d)))
((g :what) ((:what d)))))
(with-fresh-database
; (facts (a))
(facts (b))
; (facts (c))
(facts (d))
(rules ((f a) (a))
((f bc) (b) ! (c))
((f d) (d)))
(rules ((g :what) (never))
((g :what) (f :what)))
(should-fail
(f :what)
(g :what)))
(with-fresh-database
; (facts (a))
; (facts (b))
(facts (c))
; (facts (d))
(rules ((f a) (a))
((f bc) (b) ! (c))
((f d) (d)))
(rules ((g :what) (never))
((g :what) (f :what)))
(should-fail
(f :what)
(g :what))))