--- a/.lispwords Sun Jul 17 00:50:25 2016 +0000
+++ b/.lispwords Sun Jul 17 16:49:06 2016 +0000
@@ -8,3 +8,4 @@
(0 push-logic-frame-with)
(1 cell-typecase)
(1 opcode-case)
+(2 define-invocation)
--- a/src/make-quickutils.lisp Sun Jul 17 00:50:25 2016 +0000
+++ b/src/make-quickutils.lisp Sun Jul 17 16:49:06 2016 +0000
@@ -5,6 +5,7 @@
:utilities '(:define-constant
:set-equal
:curry
+ :rcurry
:switch
:ensure-boolean
:while
--- a/src/quickutils.lisp Sun Jul 17 00:50:25 2016 +0000
+++ b/src/quickutils.lisp Sun Jul 17 16:49:06 2016 +0000
@@ -2,7 +2,7 @@
;;;; See http://quickutil.org for details.
;;;; To regenerate:
-;;;; (qtlc:save-utils-as "quickutils.lisp" :utilities '(:DEFINE-CONSTANT :SET-EQUAL :CURRY :SWITCH :ENSURE-BOOLEAN :WHILE :UNTIL :TREE-MEMBER-P :TREE-COLLECT :WITH-GENSYMS :ONCE-ONLY :ZIP :ALIST-TO-HASH-TABLE :MAP-TREE :WEAVE :RANGE :ALIST-PLIST :EQUIVALENCE-CLASSES :MAP-PRODUCT) :ensure-package T :package "BONES.QUICKUTILS")
+;;;; (qtlc:save-utils-as "quickutils.lisp" :utilities '(:DEFINE-CONSTANT :SET-EQUAL :CURRY :RCURRY :SWITCH :ENSURE-BOOLEAN :WHILE :UNTIL :TREE-MEMBER-P :WITH-GENSYMS :ONCE-ONLY :ZIP :ALIST-TO-HASH-TABLE :MAP-TREE :WEAVE :ALIST-PLIST :EQUIVALENCE-CLASSES :MAP-PRODUCT) :ensure-package T :package "BONES.QUICKUTILS")
(eval-when (:compile-toplevel :load-toplevel :execute)
(unless (find-package "BONES.QUICKUTILS")
@@ -15,13 +15,12 @@
(when (boundp '*utilities*)
(setf *utilities* (union *utilities* '(:DEFINE-CONSTANT :SET-EQUAL
:MAKE-GENSYM-LIST :ENSURE-FUNCTION
- :CURRY :STRING-DESIGNATOR
+ :CURRY :RCURRY :STRING-DESIGNATOR
:WITH-GENSYMS :EXTRACT-FUNCTION-NAME
:SWITCH :ENSURE-BOOLEAN :UNTIL :WHILE
- :TREE-MEMBER-P :TREE-COLLECT
- :ONCE-ONLY :TRANSPOSE :ZIP
- :ALIST-TO-HASH-TABLE :MAP-TREE :WEAVE
- :RANGE :SAFE-ENDP :ALIST-PLIST
+ :TREE-MEMBER-P :ONCE-ONLY :TRANSPOSE
+ :ZIP :ALIST-TO-HASH-TABLE :MAP-TREE
+ :WEAVE :SAFE-ENDP :ALIST-PLIST
:EQUIVALENCE-CLASSES :MAPPEND
:MAP-PRODUCT))))
@@ -118,6 +117,16 @@
(apply ,fun ,@curries more)))))
+ (defun rcurry (function &rest arguments)
+ "Returns a function that applies the arguments it is called
+with and `arguments` to `function`."
+ (declare (optimize (speed 3) (safety 1) (debug 1)))
+ (let ((fn (ensure-function function)))
+ (lambda (&rest more)
+ (declare (dynamic-extent more))
+ (multiple-value-call fn (values-list more) (values-list arguments)))))
+
+
(deftype string-designator ()
"A string designator type. A string designator is either a string, a symbol,
or a character."
@@ -240,25 +249,6 @@
(rec tree)))
- (defun tree-collect (predicate tree)
- "Returns a list of every node in the `tree` that satisfies the `predicate`. If there are any improper lists in the tree, the `predicate` is also applied to their dotted elements."
- (let ((sentinel (gensym)))
- (flet ((my-cdr (obj)
- (cond ((consp obj)
- (let ((result (cdr obj)))
- (if (listp result)
- result
- (list result sentinel))))
- (t
- (list sentinel)))))
- (loop :for (item . rest) :on tree :by #'my-cdr
- :until (eq item sentinel)
- :if (funcall predicate item) collect item
- :else
- :if (listp item)
- :append (tree-collect predicate item)))))
-
-
(defmacro once-only (specs &body forms)
"Evaluates `forms` with symbols specified in `specs` rebound to temporary
variables, ensuring that each initform is evaluated only once.
@@ -337,14 +327,6 @@
(apply #'mapcan #'list lists))
- (defun range (start end &key (step 1) (key 'identity))
- "Return the list of numbers `n` such that `start <= n < end` and
-`n = start + k*step` for suitable integers `k`. If a function `key` is
-provided, then apply it to each number."
- (assert (<= start end))
- (loop :for i :from start :below end :by step :collecting (funcall key i)))
-
-
(declaim (inline safe-endp))
(defun safe-endp (x)
(declare (optimize safety))
@@ -423,9 +405,9 @@
(%map-product (ensure-function function) (cons list more-lists))))
(eval-when (:compile-toplevel :load-toplevel :execute)
- (export '(define-constant set-equal curry switch eswitch cswitch
- ensure-boolean while until tree-member-p tree-collect with-gensyms
+ (export '(define-constant set-equal curry rcurry switch eswitch cswitch
+ ensure-boolean while until tree-member-p with-gensyms
with-unique-names once-only zip alist-to-hash-table map-tree weave
- range alist-plist plist-alist equivalence-classes map-product)))
+ alist-plist plist-alist equivalence-classes map-product)))
;;;; END OF quickutils.lisp ;;;;
--- a/src/wam/compiler/7-rendering.lisp Sun Jul 17 00:50:25 2016 +0000
+++ b/src/wam/compiler/7-rendering.lisp Sun Jul 17 16:49:06 2016 +0000
@@ -132,8 +132,8 @@
:do (incf address size)))))
-(defun render-query (wam instructions)
- (render-bytecode (wam-code wam) instructions 0 +maximum-query-size+))
+(defun render-query-into (storage instructions)
+ (render-bytecode storage instructions 0 +maximum-query-size+))
(defun mark-label (wam functor arity address)
--- a/src/wam/compiler/8-ui.lisp Sun Jul 17 00:50:25 2016 +0000
+++ b/src/wam/compiler/8-ui.lisp Sun Jul 17 16:49:06 2016 +0000
@@ -8,19 +8,33 @@
;;; The final phase wraps everything else up into a sane UI.
+(defun %compile-query-into (storage query)
+ (multiple-value-bind (instructions permanent-variables)
+ (precompile-query query)
+ (optimize-instructions instructions)
+ (values permanent-variables
+ (render-query-into storage instructions))))
+
(defun compile-query (wam query)
"Compile `query` into the query section of the WAM's code store.
`query` should be a list of goal terms.
- Returns the permanent variables.
+ Returns the permanent variables and the size of the compiled bytecode.
"
- (multiple-value-bind (instructions permanent-variables)
- (precompile-query query)
- (optimize-instructions instructions)
- (render-query wam instructions)
- permanent-variables))
+ (%compile-query-into (wam-code wam) query))
+
+(defun compile-query-into (storage query)
+ "Compile `query` into the given array `storage`.
+
+ `query` should be a list of goal terms.
+
+ Returns the permanent variables and the size of the compiled bytecode.
+
+ "
+ (%compile-query-into storage query))
+
(defun compile-rules (wam rules)
"Compile `rules` into the WAM's code store.
--- a/src/wam/types.lisp Sun Jul 17 00:50:25 2016 +0000
+++ b/src/wam/types.lisp Sun Jul 17 16:49:06 2016 +0000
@@ -54,6 +54,9 @@
(deftype query-code-holder ()
`(simple-array code-word (,+maximum-query-size+)))
+(deftype query-size ()
+ `(integer 0 ,+maximum-query-size+))
+
(deftype instruction-size ()
`(integer 1 ,+maximum-instruction-size+))
--- a/src/wam/ui.lisp Sun Jul 17 00:50:25 2016 +0000
+++ b/src/wam/ui.lisp Sun Jul 17 16:49:06 2016 +0000
@@ -21,20 +21,21 @@
;;;; Normalization
-(defun normalize-term (term)
- ;; Normally a rule consists of a head terms and multiple body terms, like so:
- ;;
- ;; (likes sally ?who) (likes ?who cats)
- ;;
- ;; But sometimes people are lazy and don't include the parens around
- ;; zero-arity predicates:
- ;;
- ;; (happy steve) sunny
- (if (and (not (variablep term))
- (symbolp term)
- (not (eq term '!))) ; jesus
- (list term)
- term))
+(eval-when (:compile-toplevel :load-toplevel :execute)
+ (defun normalize-term (term)
+ ;; Normally a rule consists of a head terms and many body terms, like so:
+ ;;
+ ;; (likes sally ?who) (likes ?who cats)
+ ;;
+ ;; But sometimes people are lazy and don't include the parens around
+ ;; zero-arity predicates:
+ ;;
+ ;; (happy steve) sunny
+ (if (and (not (variablep term))
+ (symbolp term)
+ (not (eq term '!))) ; jesus
+ (list term)
+ term)))
;;;; Assertion
@@ -86,58 +87,78 @@
;;;; Querying
+(defun perform-aot-query (code size vars result-function)
+ (assert *database* (*database*) "No database.")
+ (run-aot-compiled-query *database* code size vars
+ :result-function result-function))
+
(defun perform-query (terms result-function)
(assert *database* (*database*) "No database.")
(run-query *database* (mapcar #'normalize-term terms)
:result-function result-function))
-(defun invoke-query (&rest terms)
+(defmacro define-invocation ((name aot-name) arglist &body body)
+ (with-gensyms (terms data code size vars)
+ `(progn
+ (defun ,name ,(append arglist `(&rest ,terms))
+ (macrolet ((invoke (result-function)
+ `(perform-query ,',terms ,result-function)))
+ ,@body))
+ (defun ,aot-name ,(append arglist `(,data))
+ (destructuring-bind (,code ,size ,vars) ,data
+ (macrolet ((invoke (result-function)
+ `(perform-aot-query ,',code ,',size ,',vars
+ ,result-function)))
+ ,@body))))))
+
+
+(define-invocation (invoke-query invoke-query-aot) ()
(let ((result nil)
(succeeded nil))
- (perform-query terms (lambda (r)
- (setf result r
- succeeded t)
- t))
+ (invoke (lambda (r)
+ (setf result r
+ succeeded t)
+ t))
(values result succeeded)))
-(defun invoke-query-all (&rest terms)
+(define-invocation (invoke-query-all invoke-query-all-aot) ()
(let ((results nil))
- (perform-query terms (lambda (result)
- (push result results)
- nil))
- (nreverse results)))
-
-(defun invoke-query-map (function &rest terms)
- (let ((results nil))
- (perform-query terms (lambda (result)
- (push (funcall function result) results)
- nil))
+ (invoke (lambda (result)
+ (push result results)
+ nil))
(nreverse results)))
-(defun invoke-query-do (function &rest terms)
- (perform-query terms (lambda (result)
- (funcall function result)
- nil))
+(define-invocation (invoke-query-map invoke-query-map-aot) (function)
+ (let ((results nil))
+ (invoke (lambda (result)
+ (push (funcall function result) results)
+ nil))
+ (nreverse results)))
+
+(define-invocation (invoke-query-do invoke-query-do-aot) (function)
+ (invoke (lambda (result)
+ (funcall function result)
+ nil))
(values))
-(defun invoke-query-find (predicate &rest terms)
+(define-invocation (invoke-query-find invoke-query-find-aot) (predicate)
(let ((results nil)
(succeeded nil))
- (perform-query terms (lambda (result)
- (if (funcall predicate result)
- (progn (setf results result
- succeeded t)
- t)
- nil)))
+ (invoke (lambda (result)
+ (if (funcall predicate result)
+ (progn (setf results result
+ succeeded t)
+ t)
+ nil)))
(values results succeeded)))
-(defun invoke-prove (&rest terms)
+(define-invocation (invoke-prove invoke-prove-aot) ()
(let ((succeeded nil))
- (perform-query terms (lambda (result)
- (declare (ignore result))
- (setf succeeded t)
- t))
+ (invoke (lambda (result)
+ (declare (ignore result))
+ (setf succeeded t)
+ t))
succeeded))
@@ -163,6 +184,39 @@
`(invoke-prove ,@(quote-terms terms)))
+;;;; Chili Dogs
+(eval-when (:compile-toplevel :load-toplevel :execute)
+ (defun make-aot-data-form (terms)
+ (with-gensyms (code size vars)
+ `(load-time-value
+ (let* ((,code (allocate-query-holder)))
+ (multiple-value-bind (,vars ,size)
+ (compile-query-into
+ ,code ',(->> terms
+ (mapcar #'eval)
+ (mapcar #'normalize-term)))
+ (list ,code ,size ,vars)))
+ t))))
+
+
+(defmacro define-invocation-compiler-macro (name aot-name arglist)
+ `(define-compiler-macro ,name (&whole form
+ ,@arglist
+ &rest terms
+ &environment env)
+ (if (every (rcurry #'constantp env) terms)
+ `(,',aot-name ,,@arglist ,(make-aot-data-form terms))
+ form)))
+
+
+(define-invocation-compiler-macro invoke-query invoke-query-aot ())
+(define-invocation-compiler-macro invoke-query-all invoke-query-all-aot ())
+(define-invocation-compiler-macro invoke-query-map invoke-query-map-aot (function))
+(define-invocation-compiler-macro invoke-query-do invoke-query-do-aot (function))
+(define-invocation-compiler-macro invoke-query-find invoke-query-find-aot (predicate))
+(define-invocation-compiler-macro invoke-prove invoke-prove-aot ())
+
+
;;;; Debugging
(defun dump (&optional full-code)
(dump-wam-full *database*)
--- a/src/wam/vm.lisp Sun Jul 17 00:50:25 2016 +0000
+++ b/src/wam/vm.lisp Sun Jul 17 16:49:06 2016 +0000
@@ -873,24 +873,42 @@
(error "Fell off the end of the program code store."))))
(values))
-(defun run-query (wam term &key (result-function
- (lambda (results)
- (declare (ignore results)))))
- "Compile query `term` and run the instructions on the `wam`.
- Resets the heap, etc before running.
-
- When `*step*` is true, break into the debugger before calling the procedure and
- after each instruction.
-
- "
- (let ((vars (compile-query wam term)))
- (setf (wam-program-counter wam) 0
- (wam-continuation-pointer wam) +code-sentinel+)
- (run wam (lambda ()
- (funcall result-function
- (extract-query-results wam vars)))))
+(defun %run-query (wam vars result-function)
+ (setf (wam-program-counter wam) 0
+ (wam-continuation-pointer wam) +code-sentinel+)
+ (run wam (lambda ()
+ (funcall result-function
+ (extract-query-results wam vars))))
(wam-reset! wam)
(values))
+(defun run-query (wam terms &key (result-function
+ (lambda (results)
+ (declare (ignore results)))))
+ "Compile query `terms` and run the instructions on the `wam`.
+ Resets the heap, etc after running.
+
+ When `*step*` is true, break into the debugger before calling the procedure
+ and after each instruction.
+
+ "
+ (%run-query wam (compile-query wam terms) result-function))
+
+(defun run-aot-compiled-query (wam query-code query-size query-vars
+ &key (result-function
+ (lambda (results)
+ (declare (ignore results)))))
+ "Run the AOT-compiled query `code`/`vars` on the `wam`.
+
+ Resets the heap, etc after running.
+
+ When `*step*` is true, break into the debugger before calling the procedure
+ and after each instruction.
+
+ "
+ (wam-load-query-code! wam query-code query-size)
+ (%run-query wam query-vars result-function))
+
+
--- a/src/wam/wam.lisp Sun Jul 17 00:50:25 2016 +0000
+++ b/src/wam/wam.lisp Sun Jul 17 16:49:06 2016 +0000
@@ -10,6 +10,13 @@
:initial-element 0
:element-type 'code-word))
+(defun allocate-query-holder ()
+ (make-array +maximum-query-size+
+ :adjustable nil
+ :initial-element 0
+ :element-type 'code-word))
+
+
(defun allocate-wam-type-store (size)
;; The main WAM store(s) contain three separate blocks of values:
;;
@@ -638,9 +645,12 @@
(remhash functor atable))))
-(defun wam-load-query-code! (wam query-code)
- (setf (subseq (wam-code wam) 0) query-code)
- (values))
+(declaim (ftype (function (wam query-code-holder query-size)
+ (values null &optional))
+ wam-load-query-code!))
+(defun wam-load-query-code! (wam query-code query-size)
+ (setf (subseq (wam-code wam) 0 query-size) query-code)
+ nil)
;;;; Logic Stack