--- a/src/wam/bytecode.lisp Fri Jul 15 23:12:18 2016 +0000
+++ b/src/wam/bytecode.lisp Sat Jul 16 01:34:04 2016 +0000
@@ -104,13 +104,13 @@
"
(#.+opcode-noop+ 1)
- (#.+opcode-get-structure+ 3)
+ (#.+opcode-get-structure+ 4)
(#.+opcode-get-variable-local+ 3)
(#.+opcode-get-variable-stack+ 3)
(#.+opcode-get-value-local+ 3)
(#.+opcode-get-value-stack+ 3)
- (#.+opcode-put-structure+ 3)
+ (#.+opcode-put-structure+ 4)
(#.+opcode-put-variable-local+ 3)
(#.+opcode-put-variable-stack+ 3)
(#.+opcode-put-value-local+ 3)
@@ -122,8 +122,8 @@
(#.+opcode-subterm-value-stack+ 2)
(#.+opcode-subterm-void+ 2)
- (#.+opcode-jump+ 2)
- (#.+opcode-call+ 2)
+ (#.+opcode-jump+ 3)
+ (#.+opcode-call+ 3)
(#.+opcode-dynamic-jump+ 1)
(#.+opcode-dynamic-call+ 1)
(#.+opcode-proceed+ 1)
--- a/src/wam/compiler/5-precompilation.lisp Fri Jul 15 23:12:18 2016 +0000
+++ b/src/wam/compiler/5-precompilation.lisp Sat Jul 16 01:34:04 2016 +0000
@@ -201,7 +201,8 @@
;; OP functor reg
(push destination-register seen)
(push-instruction (find-opcode-structure mode)
- (cons functor arity)
+ functor
+ arity
destination-register))
(handle-list (register)
(push register seen)
@@ -219,9 +220,7 @@
;; DYNAMIC-[CALL/JUMP]
(push-instruction (if is-jump :dynamic-jump :dynamic-call))
;; [CALL/JUMP] functor
- (push-instruction
- (if is-jump :jump :call)
- (cons functor arity)))
+ (push-instruction (if is-jump :jump :call) functor arity))
;; This is a little janky, but at this point the body goals have been
;; turned into one single stream of tokens, so we don't have a nice
;; clean way to tell when one ends. But in practice, a body goal is
--- a/src/wam/compiler/6-optimization.lisp Fri Jul 15 23:12:18 2016 +0000
+++ b/src/wam/compiler/6-optimization.lisp Sat Jul 16 01:34:04 2016 +0000
@@ -71,13 +71,13 @@
:do
(match (circle-value node)
- (`(:put-structure (,functor . 0) ,register)
+ (`(:put-structure ,functor 0 ,register)
(setf node
(if (register-argument-p register)
(optimize-put-constant node functor register)
(optimize-subterm-constant-query node functor register))))
- (`(:get-structure (,functor . 0) ,register)
+ (`(:get-structure ,functor 0 ,register)
(setf node
(if (register-argument-p register)
(optimize-get-constant node functor register)
--- a/src/wam/constants.lisp Fri Jul 15 23:12:18 2016 +0000
+++ b/src/wam/constants.lisp Sat Jul 16 01:34:04 2016 +0000
@@ -49,7 +49,7 @@
:documentation
"The maximum size (in bytes of bytecode) a query may compile to.")
-(define-constant +maximum-instruction-size+ 3
+(define-constant +maximum-instruction-size+ 4
:documentation
"The maximum number of code words an instruction (including opcode) might be.")
--- a/src/wam/dump.lisp Fri Jul 15 23:12:18 2016 +0000
+++ b/src/wam/dump.lisp Sat Jul 16 01:34:04 2016 +0000
@@ -11,9 +11,8 @@
"unbound variable "
(format nil "var pointer to ~8,'0X " r)))
((:structure s) (format nil "struct pointer to ~8,'0X " s))
- ((:functor f) (destructuring-bind (functor . arity) f
- (format nil "~A/~D " functor arity)))
- ((:constant c) (format nil "~A/0 " c))
+ ((:functor f) (format nil "functor symbol ~A " f))
+ ((:constant c) (format nil "constant symbol ~A " c))
(t ""))))
@@ -43,7 +42,7 @@
:do (progn
(print-cell address indent)
(cell-typecase (wam address)
- ((:functor f) (setf indent (cdr f)))
+ ((:functor f n) (declare (ignore f)) (setf indent n))
(t (when (not (zerop indent))
(decf indent)))))))
(when (< to (wam-heap-pointer wam))
@@ -163,16 +162,18 @@
(defmethod instruction-details ((opcode (eql +opcode-get-structure+)) arguments)
- (format nil "GETS~A ; X~A = ~A"
+ (format nil "GETS~A ; X~A = ~A/~D"
(pretty-arguments arguments)
- (second arguments)
- (pretty-functor (first arguments))))
+ (third arguments)
+ (first arguments)
+ (second arguments)))
(defmethod instruction-details ((opcode (eql +opcode-put-structure+)) arguments)
- (format nil "PUTS~A ; X~A <- new ~A"
+ (format nil "PUTS~A ; X~A <- new ~A/~D"
(pretty-arguments arguments)
- (second arguments)
- (pretty-functor (first arguments))))
+ (third arguments)
+ (first arguments)
+ (second arguments)))
(defmethod instruction-details ((opcode (eql +opcode-get-variable-local+)) arguments)
(format nil "GVAR~A ; X~A <- A~A"
@@ -223,14 +224,16 @@
(first arguments)))
(defmethod instruction-details ((opcode (eql +opcode-call+)) arguments)
- (format nil "CALL~A ; call ~A"
+ (format nil "CALL~A ; call ~A/~D"
(pretty-arguments arguments)
- (first arguments)))
+ (first arguments)
+ (second arguments)))
(defmethod instruction-details ((opcode (eql +opcode-jump+)) arguments)
- (format nil "JUMP~A ; jump ~A"
+ (format nil "JUMP~A ; jump ~A/~D"
(pretty-arguments arguments)
- (first arguments)))
+ (first arguments)
+ (second arguments)))
(defmethod instruction-details ((opcode (eql +opcode-dynamic-call+)) arguments)
(format nil "DYCL~A ; dynamic call"
--- a/src/wam/types.lisp Fri Jul 15 23:12:18 2016 +0000
+++ b/src/wam/types.lisp Sat Jul 16 01:34:04 2016 +0000
@@ -39,9 +39,6 @@
(deftype arity ()
`(integer 0 ,+maximum-arity+))
-(deftype functor ()
- '(cons fname arity))
-
(deftype code-index ()
;; either an address or the sentinel
--- a/src/wam/vm.lisp Fri Jul 15 23:12:18 2016 +0000
+++ b/src/wam/vm.lisp Sat Jul 16 01:34:04 2016 +0000
@@ -34,10 +34,12 @@
"
(wam-heap-push! wam +cell-type-list+ (1+ (wam-heap-pointer wam))))
-(defun* push-new-functor! ((wam wam) (functor functor))
+(defun* push-new-functor! ((wam wam) (functor fname) (arity arity))
(:returns heap-index)
- "Push a new functor cell onto the heap, returning its address."
- (wam-heap-push! wam +cell-type-functor+ functor))
+ "Push a new functor cell pair onto the heap, returning its address."
+ (prog1
+ (wam-heap-push! wam +cell-type-functor+ functor)
+ (wam-heap-push! wam +cell-type-lisp-object+ arity)))
(defun* push-new-constant! ((wam wam) (constant fname))
(:returns heap-index)
@@ -45,10 +47,12 @@
(wam-heap-push! wam +cell-type-constant+ constant))
-(defun* functors-match-p ((f1 functor) (f2 functor))
+(defun* functors-match-p ((f1 fname) (a1 arity)
+ (f2 fname) (a2 arity))
(:returns boolean)
"Return whether the two functor cell values represent the same functor."
- (equal f1 f2))
+ (and (eq f1 f2)
+ (= a1 a2)))
(defun* constants-match-p ((c1 fname) (c2 fname))
(:returns boolean)
@@ -228,14 +232,15 @@
(let* ((s1 (wam-store-value wam d1)) ; find where they
(s2 (wam-store-value wam d2)) ; start on the heap
(f1 (wam-store-value wam s1)) ; grab the
- (f2 (wam-store-value wam s2))) ; functors
- (if (functors-match-p f1 f2)
+ (f2 (wam-store-value wam s2)) ; functors
+ (a1 (wam-store-value wam (1+ s1))) ; and the
+ (a2 (wam-store-value wam (1+ s2)))) ; arities
+ (if (functors-match-p f1 a1 f2 a2)
;; If the functors match, push their pairs of arguments onto
;; the stack to be unified.
- (loop :with arity = (cdr f1)
- :repeat arity
- :for subterm1 :from (1+ s1)
- :for subterm2 :from (1+ s2)
+ (loop :repeat a1
+ :for subterm1 :from (+ 2 s1)
+ :for subterm2 :from (+ 2 s2)
:do (wam-unification-stack-push! wam subterm1 subterm2))
;; Otherwise we're hosed.
(backtrack! wam))))
@@ -335,11 +340,12 @@
;;;; Query Instructions
(define-instruction (%put-structure)
((wam wam)
- (functor functor)
+ (functor fname)
+ (arity arity)
(register register-index))
(wam-set-local-register! wam register
+cell-type-structure+
- (push-new-functor! wam functor))
+ (push-new-functor! wam functor arity))
(setf (wam-mode wam) :write))
(define-instruction (%put-list)
@@ -370,14 +376,16 @@
;;;; Program Instructions
(define-instruction (%get-structure) ((wam wam)
- (functor functor)
+ (functor fname)
+ (arity arity)
(register register-index))
(cell-typecase (wam (deref wam register) address)
- ;; If the register points at an unbound reference cell, we push two new
+ ;; If the register points at an unbound reference cell, we push three new
;; cells onto the heap:
;;
;; | N | STR | N+1 |
- ;; | N+1 | FUN | f/n |
+ ;; | N+1 | FUN | f |
+ ;; | N+2 | OBJ | n |
;; | | | | <- S
;;
;; Then we bind this reference cell to point at the new structure, set
@@ -389,34 +397,30 @@
;; mode).
(:reference
(let ((structure-address (push-new-structure! wam))
- (functor-address (push-new-functor! wam functor)))
+ (functor-address (push-new-functor! wam functor arity)))
(bind! wam address structure-address)
(setf (wam-mode wam) :write
- (wam-subterm wam) (1+ functor-address))))
+ (wam-subterm wam) (+ 2 functor-address))))
;; If the register points at a structure cell, then we look at where
- ;; that cell points (which will be the functor cell for the structure):
+ ;; that cell points (which will be the functor for the structure):
;;
;; | N | STR | M | points at the structure, not necessarily contiguous
;; | ... |
- ;; | M | FUN | f/2 | the functor (hopefully it matches)
- ;; | M+1 | ... | ... | pieces of the structure, always contiguous
- ;; | M+2 | ... | ... | and always right after the functor
+ ;; | M | FUN | f | the functor (hopefully it matches)
+ ;; | M+1 | OBJ | 2 | the arity (hopefully it matches)
+ ;; | M+2 | ... | ... | pieces of the structure, always contiguous
+ ;; | M+3 | ... | ... | and always right after the functor
;;
;; If it matches the functor we're looking for, we can proceed. We set
;; the S register to the address of the first subform we need to match
- ;; (M+1 in the example above).
- ;;
- ;; What about if it's a 0-arity functor? The S register will be set to
- ;; garbage. But that's okay, because we know the next thing in the
- ;; stream of instructions will be another get-structure and we'll just
- ;; blow away the S register there.
+ ;; (M+2 in the example above).
((:structure functor-address)
(cell-typecase (wam functor-address)
- ((:functor f)
- (if (functors-match-p functor f)
+ ((:functor f n)
+ (if (functors-match-p functor arity f n)
(setf (wam-mode wam) :read
- (wam-subterm wam) (1+ functor-address))
+ (wam-subterm wam) (+ 2 functor-address))
(backtrack! wam)))))
;; Otherwise we can't unify, so backtrack.
@@ -525,10 +529,9 @@
;; argument registers before we call it. Luckily all the arguments
;; conveniently live contiguously right after the functor cell.
(cell-typecase (wam functor-address)
- ((:functor f)
- (destructuring-bind (functor . arity) f
- (load-arguments arity (1+ functor-address))
- (%go functor arity)))))
+ ((:functor functor arity)
+ (load-arguments arity (+ 2 functor-address))
+ (%go functor arity))))
;; Zero-arity functors don't need to set up anything at all -- we can
;; just call them immediately.
@@ -542,15 +545,13 @@
(t (error "Cannot dynamically call something other than a structure.")))))
-(define-instruction (%jump) ((wam wam) (functor functor))
- (%%procedure-call wam
- (car functor) (cdr functor)
+(define-instruction (%jump) ((wam wam) (functor fname) (arity arity))
+ (%%procedure-call wam functor arity
(instruction-size +opcode-jump+)
t))
-(define-instruction (%call) ((wam wam) (functor functor))
- (%%procedure-call wam
- (car functor) (cdr functor)
+(define-instruction (%call) ((wam wam) (functor fname) (arity arity))
+ (%%procedure-call wam functor arity
(instruction-size +opcode-call+)
nil))
@@ -766,12 +767,11 @@
((:structure s) (recur s))
((:list l) (cons (recur l) (recur (1+ l))))
((:constant c) c)
- ((:functor f)
- (destructuring-bind (functor . arity) f
- (list* functor
- (loop :repeat arity
- :for subterm :from (+ address 1)
- :collect (recur subterm)))))
+ ((:functor functor arity)
+ (list* functor
+ (loop :repeat arity
+ :for subterm :from (+ 2 address)
+ :collect (recur subterm))))
((:lisp-object o) o)
(t (error "What to heck is this?")))))
(mapcar #'recur addresses))))
@@ -933,9 +933,7 @@
term
&key
((result-function function)
- (lambda (results) (declare (ignore results))))
- ((status-function function)
- (lambda (failp) (declare (ignore failp)))))
+ (lambda (results) (declare (ignore results)))))
"Compile query `term` and run the instructions on the `wam`.
Resets the heap, etc before running.
@@ -945,14 +943,12 @@
"
(let ((vars (compile-query wam term)))
- (wam-reset! wam)
(setf (wam-program-counter wam) 0
(wam-continuation-pointer wam) +code-sentinel+)
(run wam (lambda ()
(funcall result-function
- (extract-query-results wam vars))))
- (when status-function
- (funcall status-function (wam-fail wam))))
+ (extract-query-results wam vars)))))
+ (wam-reset! wam)
(values))
--- a/src/wam/wam.lisp Fri Jul 15 23:12:18 2016 +0000
+++ b/src/wam/wam.lisp Sat Jul 16 01:34:04 2016 +0000
@@ -195,14 +195,14 @@
(defun* ,name ((wam wam) (address store-index))
(:returns ,return-type)
(aref (wam-value-store wam) address)))))
- (define-unsafe %unsafe-null-value (eql 0))
- (define-unsafe %unsafe-structure-value store-index)
- (define-unsafe %unsafe-reference-value store-index)
- (define-unsafe %unsafe-functor-value functor)
- (define-unsafe %unsafe-constant-value fname)
- (define-unsafe %unsafe-list-value store-index)
+ (define-unsafe %unsafe-null-value (eql 0))
+ (define-unsafe %unsafe-structure-value store-index)
+ (define-unsafe %unsafe-reference-value store-index)
+ (define-unsafe %unsafe-functor-value fname)
+ (define-unsafe %unsafe-constant-value fname)
+ (define-unsafe %unsafe-list-value store-index)
(define-unsafe %unsafe-lisp-object-value t)
- (define-unsafe %unsafe-stack-value stack-word))
+ (define-unsafe %unsafe-stack-value stack-word))
(defun %type-designator-constant (designator)
@@ -226,6 +226,30 @@
(:list '%unsafe-list-value)
(:lisp-object '%unsafe-lisp-object-value)))
+(defun parse-cell-typecase-clause (wam address clause)
+ "Parse a `cell-typecase` clause into the appropriate `ecase` clause."
+ (destructuring-bind (binding . body) clause
+ (destructuring-bind
+ (type-designator &optional value-symbol secondary-value-symbol)
+ (if (symbolp binding) (list binding) binding) ; normalize binding
+ (let ((primary-let-binding
+ (when value-symbol
+ `((,value-symbol (,(%type-designator-accessor type-designator)
+ ,wam ,address)))))
+ (secondary-let-binding
+ (when secondary-value-symbol
+ `((,secondary-value-symbol
+ ,(ecase type-designator
+ (:functor
+ `(the arity (%unsafe-lisp-object-value ; yolo
+ ,wam
+ (1+ ,address))))))))))
+ ; build the ecase clause (const ...body...)
+ (list
+ (%type-designator-constant type-designator)
+ `(let (,@primary-let-binding
+ ,@secondary-let-binding)
+ ,@body))))))
(defmacro cell-typecase ((wam address &optional address-symbol) &rest clauses)
"Dispatch on the type of the cell at `address` in the WAM store.
@@ -252,31 +276,15 @@
"
(once-only (wam address)
- (labels
- ((normalize-binding (binding)
- (cond
- ((symbolp binding) (list binding nil))
- ((= 1 (length binding)) (list (car binding) nil))
- (t binding)))
- (parse-clause (clause)
- (destructuring-bind (binding . body) clause
- (destructuring-bind (type-designator value-symbol)
- (normalize-binding binding)
- `(,(%type-designator-constant type-designator)
- (let (,@(when value-symbol
- (list
- `(,value-symbol
- (,(%type-designator-accessor type-designator)
- ,wam ,address)))))
- ,@body))))))
- `(progn
- (policy-cond:policy-if (or (= safety 3) (= debug 3))
- (wam-sanity-check-store-read ,wam ,address)
- nil)
- (let (,@(when address-symbol
- (list `(,address-symbol ,address))))
- (case (wam-store-type ,wam ,address)
- ,@(mapcar #'parse-clause clauses)))))))
+ `(progn
+ (policy-cond:policy-if (or (= safety 3) (= debug 3))
+ (wam-sanity-check-store-read ,wam ,address)
+ nil)
+ (let (,@(when address-symbol
+ (list `(,address-symbol ,address))))
+ (case (wam-store-type ,wam ,address)
+ ,@(mapcar (curry #'parse-cell-typecase-clause wam address)
+ clauses))))))
(defmacro cell-type= (type type-designator)
@@ -708,6 +716,7 @@
;; todo we can't elide this once we start storing live objects... :(
(wam-reset-local-registers! wam)
nil) ; fuck it
+ (fill (wam-code wam) 0 :start 0 :end +maximum-query-size+)
(setf (wam-program-counter wam) 0
(wam-continuation-pointer wam) 0
(wam-environment-pointer wam) +stack-start+