--- a/bones.asd Mon Apr 18 15:38:02 2016 +0000
+++ b/bones.asd Mon Apr 18 18:43:12 2016 +0000
@@ -19,9 +19,11 @@
:components ((:file "src/quickutils") ; quickutils package ordering crap
(:file "package")
(:module "src"
+ :serial t
:components ((:file "paip")
(:file "utils")
(:module "wam"
+ :serial t
:components ((:file "constants")
(:file "types")
(:file "cells")
--- a/src/wam/bytecode.lisp Mon Apr 18 15:38:02 2016 +0000
+++ b/src/wam/bytecode.lisp Mon Apr 18 18:43:12 2016 +0000
@@ -2,13 +2,15 @@
;;;; Opcodes
(defun* instruction-size ((opcode opcode))
- (:returns (integer 0 3))
+ (:returns (integer 1 3))
"Return the size of an instruction for the given opcode.
The size includes one word for the opcode itself and one for each argument.
"
(eswitch (opcode)
+ (+opcode-noop+ 1)
+
(+opcode-get-structure-local+ 3)
(+opcode-unify-variable-local+ 2)
(+opcode-unify-variable-stack+ 2)
@@ -32,12 +34,14 @@
(+opcode-call+ 2)
(+opcode-proceed+ 1)
(+opcode-allocate+ 2)
- (+opcode-deallocate+ 1)))
+ (+opcode-deallocate+ 1)
+ (+opcode-done+ 1)))
(defun* opcode-name ((opcode opcode))
(:returns string)
(eswitch (opcode)
+ (+opcode-noop+ "NOOP")
(+opcode-get-structure-local+ "GET-STRUCTURE")
(+opcode-unify-variable-local+ "UNIFY-VARIABLE")
(+opcode-unify-variable-stack+ "UNIFY-VARIABLE")
@@ -61,11 +65,14 @@
(+opcode-call+ "CALL")
(+opcode-proceed+ "PROCEED")
(+opcode-allocate+ "ALLOCATE")
- (+opcode-deallocate+ "DEALLOCATE")))
+ (+opcode-deallocate+ "DEALLOCATE")
+ (+opcode-done+ "DONE")))
(defun* opcode-short-name ((opcode opcode))
(:returns string)
(eswitch (opcode)
+ (+opcode-noop+ "NOOP")
+
(+opcode-get-structure-local+ "GETS")
(+opcode-unify-variable-local+ "UVAR")
(+opcode-unify-variable-stack+ "UVAR")
@@ -89,5 +96,6 @@
(+opcode-call+ "CALL")
(+opcode-proceed+ "PROC")
(+opcode-allocate+ "ALOC")
- (+opcode-deallocate+ "DEAL")))
+ (+opcode-deallocate+ "DEAL")
+ (+opcode-done+ "DONE")))
--- a/src/wam/compiler.lisp Mon Apr 18 15:38:02 2016 +0000
+++ b/src/wam/compiler.lisp Mon Apr 18 18:43:12 2016 +0000
@@ -539,72 +539,6 @@
('(:register nil :query :stack) +opcode-set-value-stack+))))
-(defun compile-tokens (wam head-tokens body-tokens store)
- "Generate a series of machine instructions from a stream of head and body
- tokens.
-
- The `head-tokens` should be program-style tokens, and are compiled in program
- mode. The `body-tokens` should be query-style tokens, and are compiled in
- query mode.
-
- Actual queries are a special case where the `head-tokens` stream is `nil`
-
- The compiled instructions will be appended to `store` using
- `code-push-instructions!`.
-
- "
- (let ((seen (list))
- (mode nil))
- (labels
- ((handle-argument (argument-register source-register)
- ;; OP X_n A_i
- (let ((newp (push-if-new source-register seen :test #'register=)))
- (code-push-instruction! store
- (find-opcode :argument newp mode source-register)
- (register-number source-register)
- (register-number argument-register))))
- (handle-structure (destination-register functor arity)
- ;; OP functor reg
- (push destination-register seen)
- (code-push-instruction! store
- (find-opcode :structure nil mode destination-register)
- (wam-ensure-functor-index wam (cons functor arity))
- (register-number destination-register)))
- (handle-call (functor arity)
- ;; CALL functor
- (code-push-instruction! store
- +opcode-call+
- (wam-ensure-functor-index wam (cons functor arity))))
- (handle-register (register)
- ;; OP reg
- (let ((newp (push-if-new register seen :test #'register=)))
- (code-push-instruction! store
- (find-opcode :register newp mode register)
- (register-number register))))
- (handle-stream (tokens)
- (loop :for token :in tokens :collect
- (ematch token
- ((guard `(:argument ,argument-register ,source-register)
- (and (eql (register-type argument-register) :argument)
- (member (register-type source-register)
- '(:local :permanent))))
- (handle-argument argument-register source-register))
- ((guard `(:structure ,destination-register ,functor ,arity)
- (member (register-type destination-register)
- '(:local :argument)))
- (handle-structure destination-register functor arity))
- (`(:call ,functor ,arity)
- (handle-call functor arity))
- ((guard register
- (typep register 'register))
- (handle-register register))))))
- (when head-tokens
- (setf mode :program)
- (handle-stream head-tokens))
- (setf mode :query)
- (handle-stream body-tokens))))
-
-
;;;; UI
(defun find-shared-variables (terms)
"Return a list of all variables shared by two or more terms."
@@ -710,6 +644,7 @@
"
(let ((store (make-query-code-store)))
(compile-clause wam store nil query)
+ (code-push-instruction! store +opcode-done+)
store))
(defun compile-program (wam rule)
--- a/src/wam/constants.lisp Mon Apr 18 15:38:02 2016 +0000
+++ b/src/wam/constants.lisp Mon Apr 18 18:43:12 2016 +0000
@@ -55,7 +55,7 @@
:documentation "The maximum allowed arity of functors.")
-(define-constant +maximum-query-size+ 256
+(define-constant +maximum-query-size+ 48
:documentation
"The maximum size (in bytes of bytecode) a query may compile to.")
@@ -85,35 +85,38 @@
;;;; Opcodes
;;; Program
-(define-constant +opcode-get-structure-local+ 0)
-(define-constant +opcode-unify-variable-local+ 1)
-(define-constant +opcode-unify-variable-stack+ 2)
-(define-constant +opcode-unify-value-local+ 3)
-(define-constant +opcode-unify-value-stack+ 4)
-(define-constant +opcode-get-variable-local+ 5)
-(define-constant +opcode-get-variable-stack+ 6)
-(define-constant +opcode-get-value-local+ 7)
-(define-constant +opcode-get-value-stack+ 8)
+(define-constant +opcode-noop+ 0)
+(define-constant +opcode-get-structure-local+ 1)
+(define-constant +opcode-unify-variable-local+ 2)
+(define-constant +opcode-unify-variable-stack+ 3)
+(define-constant +opcode-unify-value-local+ 4)
+(define-constant +opcode-unify-value-stack+ 5)
+(define-constant +opcode-get-variable-local+ 6)
+(define-constant +opcode-get-variable-stack+ 7)
+(define-constant +opcode-get-value-local+ 8)
+(define-constant +opcode-get-value-stack+ 9)
;;; Query
-(define-constant +opcode-put-structure-local+ 9)
-(define-constant +opcode-set-variable-local+ 10)
-(define-constant +opcode-set-variable-stack+ 11)
-(define-constant +opcode-set-value-local+ 12)
-(define-constant +opcode-set-value-stack+ 13)
-(define-constant +opcode-put-variable-local+ 14)
-(define-constant +opcode-put-variable-stack+ 15)
-(define-constant +opcode-put-value-local+ 16)
-(define-constant +opcode-put-value-stack+ 17)
+(define-constant +opcode-put-structure-local+ 10)
+(define-constant +opcode-set-variable-local+ 11)
+(define-constant +opcode-set-variable-stack+ 12)
+(define-constant +opcode-set-value-local+ 13)
+(define-constant +opcode-set-value-stack+ 14)
+(define-constant +opcode-put-variable-local+ 15)
+(define-constant +opcode-put-variable-stack+ 16)
+(define-constant +opcode-put-value-local+ 17)
+(define-constant +opcode-put-value-stack+ 18)
;;; Control
-(define-constant +opcode-call+ 18)
-(define-constant +opcode-proceed+ 19)
-(define-constant +opcode-allocate+ 20)
-(define-constant +opcode-deallocate+ 21)
+(define-constant +opcode-call+ 19)
+(define-constant +opcode-proceed+ 20)
+(define-constant +opcode-allocate+ 21)
+(define-constant +opcode-deallocate+ 22)
+(define-constant +opcode-done+ 23)
;;;; Debug Config
(defparameter *off-by-one* nil)
+
--- a/src/wam/dump.lisp Mon Apr 18 15:38:02 2016 +0000
+++ b/src/wam/dump.lisp Mon Apr 18 18:43:12 2016 +0000
@@ -226,7 +226,13 @@
(wam-functors wam)))
(incf addr (length instruction))))))
-(defun dump-code (wam &optional (from 0) (to (length (wam-code wam))))
+(defun dump-code
+ (wam
+ &optional
+ (from (max (- (wam-program-counter wam) 4) ; wow
+ 0)) ; this
+ (to (min (+ (wam-program-counter wam) 6) ; is
+ (length (wam-code wam))))) ; bad
(format t "CODE~%")
(dump-code-store wam (wam-code wam) from to))
--- a/src/wam/interpreter.lisp Mon Apr 18 15:38:02 2016 +0000
+++ b/src/wam/interpreter.lisp Mon Apr 18 18:43:12 2016 +0000
@@ -411,13 +411,10 @@
results))
-(defun run-program (wam functor &optional (step nil))
+(defun run-program (wam &optional (step nil))
(with-slots (code program-counter fail) wam
- (macrolet ((instruction (inst args &body body)
- `(progn
- (instruction-call wam ,inst code program-counter ,args)
- ,@body)))
- (setf program-counter (wam-code-label wam functor))
+ (macrolet ((instruction (inst args)
+ `(instruction-call wam ,inst code program-counter ,args)))
(loop
:while (and (not fail) ; failure
(not (= program-counter +code-sentinal+))) ; finished
@@ -449,11 +446,19 @@
(+opcode-get-value-stack+ (instruction %get-value-stack 2))
;; Control
(+opcode-allocate+ (instruction %allocate 1))
- ;; need to skip the PC increment for PROC/CALL/DEAL
+ ;; need to skip the PC increment for PROC/CALL/DEAL/DONE
;; TODO: this is ugly
- (+opcode-deallocate+ (instruction %deallocate 0 (return-from op)))
- (+opcode-proceed+ (instruction %proceed 0 (return-from op)))
- (+opcode-call+ (instruction %call 1 (return-from op))))
+ (+opcode-deallocate+
+ (instruction %deallocate 0)
+ (return-from op))
+ (+opcode-proceed+
+ (instruction %proceed 0)
+ (return-from op))
+ (+opcode-call+
+ (instruction %call 1)
+ (return-from op))
+ (+opcode-done+
+ (return-from run-program)))
(incf program-counter (instruction-size opcode))
(when (>= program-counter (fill-pointer code))
(error "Fell off the end of the program code store!")))))
@@ -464,42 +469,19 @@
Resets the heap, etc before running.
- When `step` is true, break into the debugger before calling the procedure.
+ When `step` is true, break into the debugger before calling the procedure and
+ after each instruction.
"
- ;; TODO: dedupe this interpreter code
- (macrolet ((instruction (inst args &body body)
- `(progn
- (instruction-call wam ,inst code pc ,args)
- ,@body)))
- (let ((code (compile-query wam term)))
- (when step
- (dump-code-store wam code))
- (wam-reset! wam)
- (loop
- :with pc = 0 ; local program counter for this hunk of query code
- :for opcode = (aref code pc)
- :do
- (progn
- (eswitch (opcode)
- (+opcode-put-structure-local+ (instruction %put-structure-local 2))
- (+opcode-set-variable-local+ (instruction %set-variable-local 1))
- (+opcode-set-variable-stack+ (instruction %set-variable-stack 1))
- (+opcode-set-value-local+ (instruction %set-value-local 1))
- (+opcode-set-value-stack+ (instruction %set-value-stack 1))
- (+opcode-put-variable-local+ (instruction %put-variable-local 2))
- (+opcode-put-variable-stack+ (instruction %put-variable-stack 2))
- (+opcode-put-value-local+ (instruction %put-value-local 2))
- (+opcode-put-value-stack+ (instruction %put-value-stack 2))
- (+opcode-call+
- (when step
- (break "Built query on the heap, about to call program code."))
- (setf (wam-continuation-pointer wam) +code-sentinal+)
- (run-program wam (aref code (+ pc 1)) step)
- (return)))
- (incf pc (instruction-size opcode))
- (when (>= pc (length code)) ; queries SHOULD always end in a CALL...
- (error "Fell off the end of the query code store!"))))))
+ (let ((code (compile-query wam term)))
+ (wam-reset! wam)
+ (wam-load-query-code! wam code)
+ (setf (wam-program-counter wam) 0
+ (wam-continuation-pointer wam) +code-sentinal+)
+ (when step
+ (format *debug-io* "Built query code:~%")
+ (dump-code-store wam code)))
+ (run-program wam step)
(if (wam-fail wam)
(princ "No.")
(princ "Yes."))
--- a/src/wam/types.lisp Mon Apr 18 15:38:02 2016 +0000
+++ b/src/wam/types.lisp Mon Apr 18 18:43:12 2016 +0000
@@ -39,7 +39,7 @@
(deftype opcode ()
- '(integer 0 21))
+ '(integer 0 23))
(deftype stack-frame-size ()
--- a/src/wam/ui.lisp Mon Apr 18 15:38:02 2016 +0000
+++ b/src/wam/ui.lisp Mon Apr 18 18:43:12 2016 +0000
@@ -2,7 +2,6 @@
(defparameter *database* nil)
-(defparameter *debug* nil)
(defmacro with-database (&body body)
`(let ((*database* (make-wam)))
@@ -12,15 +11,18 @@
(defun add-rule (rule)
(compile-program *database* rule))
-(defun perform-query (query)
- (run-query *database* query *debug*))
+(defun perform-query (query step)
+ (run-query *database* query step))
(defmacro rule (&body body)
`(add-rule ',body))
(defmacro query (&body body)
- `(perform-query ',body))
+ `(perform-query ',body nil))
+
+(defmacro query-step (&body body)
+ `(perform-query ',body t))
(defun dump ()
(dump-wam-full *database*))
--- a/src/wam/wam.lisp Mon Apr 18 15:38:02 2016 +0000
+++ b/src/wam/wam.lisp Mon Apr 18 18:43:12 2016 +0000
@@ -11,9 +11,13 @@
:reader wam-heap
:documentation "The actual heap (stack).")
(code
- :initform (make-array 1024
+ ;; The WAM bytecode is all stored in this array. The first
+ ;; `+maximum-query-size+` words are reserved for query bytecode, which will
+ ;; get loaded in (overwriting the previous query) when making a query.
+ ;; Everything after that is for the actual database.
+ :initform (make-array (+ +maximum-query-size+ 1024)
:adjustable t
- :fill-pointer 0
+ :fill-pointer +maximum-query-size+
:initial-element 0
:element-type 'code-word)
:reader wam-code
@@ -308,7 +312,7 @@
(opcode-name opcode)
(length arguments)
arguments
- (instruction-size opcode))
+ (1- (instruction-size opcode)))
(prog1
(code-push-word! store opcode)
(dolist (arg arguments)
@@ -324,6 +328,18 @@
(setf (gethash functor (wam-code-labels wam)) new-value))
+(defun* wam-load-query-code! ((wam wam) query-code)
+ (:returns :void)
+ (when (> (length query-code) +maximum-query-size+)
+ (error "WAM query store exhausted."))
+ ;; TODO: there must be a better way to do this
+ (loop :for word :across query-code
+ :for addr :from 0
+ :do (setf (aref (wam-code wam) addr)
+ word))
+ (values))
+
+
;;;; Registers
;;; The WAM has two types of registers. A register (regardless of type) always
;;; contains an index into the heap (basically a pointer to a heap cell).