--- a/src/wam/cells.lisp Fri Apr 01 17:24:39 2016 +0000
+++ b/src/wam/cells.lisp Fri Apr 01 19:16:23 2016 +0000
@@ -27,29 +27,6 @@
;;; symbol lives. Arity is the arity of the functor.
-(deftype heap-cell ()
- `(unsigned-byte ,+cell-width+))
-
-(deftype heap-cell-tag ()
- `(unsigned-byte ,+cell-tag-width+))
-
-(deftype heap-cell-value ()
- `(unsigned-byte ,+cell-value-width+))
-
-
-(deftype heap-index ()
- `(integer 0 ,(1- +heap-limit+)))
-
-(deftype register-index ()
- `(integer 0 ,(1- +register-count+)))
-
-(deftype functor-index ()
- `(integer 0 ,(1- array-total-size-limit)))
-
-(deftype arity ()
- `(integer 0 ,+maximum-arity+))
-
-
(defun* cell-type ((cell heap-cell))
(:returns heap-cell-tag)
(logand cell +cell-tag-bitmask+))
--- a/src/wam/compile.lisp Fri Apr 01 17:24:39 2016 +0000
+++ b/src/wam/compile.lisp Fri Apr 01 19:16:23 2016 +0000
@@ -1,4 +1,5 @@
(in-package #:bones.wam)
+(named-readtables:in-readtable :fare-quasiquote)
;;;; Parsing
;;; Turns p(A, q(A, B)) into something like:
@@ -278,9 +279,9 @@
arity))
-;;;; Actions
-;;; Once we have a tokenized stream we can generate the list of machine
-;;; instructions from it.
+;;;; Bytecode
+;;; Once we have a tokenized stream we can generate the machine instructions
+;;; from it.
;;;
;;; We turn:
;;;
@@ -295,34 +296,59 @@
;;; (#'%set-value 1)
;;; (#'%set-value 2)
-(defun generate-actions (tokens structure-inst unseen-var-inst seen-var-inst)
- "Generate a series of 'machine instructions' from a stream of tokens."
+(defun generate-actions (tokens store mode)
+ "Generate a series of machine instructions from a stream of tokens."
(let ((seen (list)))
- (flet ((handle-structure (register functor arity)
+ (flet ((handle-argument (register target)
+ (if (member target seen)
+ (vector-push-extend (ecase mode
+ (:program +opcode-get-value+)
+ (:query +opcode-put-value+))
+ store)
+ (progn
+ (push target seen)
+ (vector-push-extend (ecase mode
+ (:program +opcode-get-variable+)
+ (:query +opcode-put-variable+))
+ store)))
+ (vector-push-extend target store)
+ (vector-push-extend register store))
+ (handle-structure (register functor arity)
(push register seen)
- (list structure-inst functor arity register))
+ (vector-push-extend (ecase mode
+ (:program +opcode-get-structure+)
+ (:query +opcode-put-structure+))
+ store)
+ (vector-push-extend arity store) ; todo: add functor
+ (vector-push-extend register store))
(handle-register (register)
(if (member register seen)
- (list seen-var-inst register)
+ (progn
+ (vector-push-extend (ecase mode
+ (:program +opcode-get-value+)
+ (:query +opcode-set-value+))
+ store)
+ (vector-push-extend register store))
(progn
(push register seen)
- (list unseen-var-inst register)))))
- (loop :for token :in tokens
- :collect (if (consp token)
- (apply #'handle-structure token)
- (handle-register token))))))
+ (vector-push-extend (ecase mode
+ (:program +opcode-get-variable+)
+ (:query +opcode-set-variable+))
+ store)
+ (vector-push-extend register store)))))
+ (loop :for token :in tokens :collect
+ (match token
+ (`(:argument ,register ,target)
+ (handle-argument register target))
+ (`(:structure ,register ,functor ,arity)
+ (handle-structure register functor arity))
+ (register (handle-register register)))))))
-(defun generate-query-actions (tokens)
- (generate-actions tokens
- #'%put-structure
- #'%set-variable
- #'%set-value))
+(defun generate-query-actions (tokens store)
+ (generate-actions tokens store :query))
-(defun generate-program-actions (tokens)
- (generate-actions tokens
- #'%get-structure
- #'%unify-variable
- #'%unify-value))
+(defun generate-program-actions (tokens store)
+ (generate-actions tokens store :program))
;;;; UI
--- a/src/wam/constants.lisp Fri Apr 01 17:24:39 2016 +0000
+++ b/src/wam/constants.lisp Fri Apr 01 19:16:23 2016 +0000
@@ -52,7 +52,21 @@
:documentation "The maximum allowed arity of functors.")
+;;;; Opcodes
+;;; Program
(define-constant +opcode-get-structure+ 1)
(define-constant +opcode-unify-variable+ 2)
(define-constant +opcode-unify-value+ 3)
+(define-constant +opcode-get-variable+ 4)
+(define-constant +opcode-get-value+ 5)
+;;; Query
+(define-constant +opcode-put-structure+ 6)
+(define-constant +opcode-set-variable+ 7)
+(define-constant +opcode-set-value+ 8)
+(define-constant +opcode-put-variable+ 9)
+(define-constant +opcode-put-value+ 10)
+
+;;; Control
+(define-constant +opcode-call+ 11)
+(define-constant +opcode-proceed+ 12)
--- a/src/wam/dump.lisp Fri Apr 01 17:24:39 2016 +0000
+++ b/src/wam/dump.lisp Fri Apr 01 19:16:23 2016 +0000
@@ -52,15 +52,18 @@
(opcode-short-name (aref instruction 0))
(rest (coerce instruction 'list))))
-(defun dump-code (wam &optional (from 0) (to (length (wam-code wam))))
- (format t "CODE~%")
+(defun dump-code-store (code-store &optional (from 0) (to (length code-store)))
(let ((addr from))
(while (< addr to)
(format t "; ~4,'0X: " addr)
- (let ((instruction (wam-code-instruction wam addr)))
+ (let ((instruction (retrieve-instruction code-store addr)))
(format t "~A~%" (instruction-aesthetic instruction))
(incf addr (length instruction))))))
+(defun dump-code (wam &optional (from 0) (to (length (wam-code wam))))
+ (format t "CODE~%")
+ (dump-code-store (wam-code wam) from to))
+
(defun dump-wam-registers (wam)
(format t "REGISTERS:~%")
--- a/src/wam/opcodes.lisp Fri Apr 01 17:24:39 2016 +0000
+++ b/src/wam/opcodes.lisp Fri Apr 01 19:16:23 2016 +0000
@@ -5,16 +5,27 @@
(defun* instruction-size ((opcode opcode))
- (:returns (integer 0 4))
+ (:returns (integer 0 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-get-structure+ 4)
+ (+opcode-get-structure+ 3)
(+opcode-unify-variable+ 2)
- (+opcode-unify-value+ 2)))
+ (+opcode-unify-value+ 2)
+ (+opcode-get-variable+ 3)
+ (+opcode-get-value+ 3)
+
+ (+opcode-put-structure+ 3)
+ (+opcode-set-variable+ 2)
+ (+opcode-set-value+ 2)
+ (+opcode-put-variable+ 3)
+ (+opcode-put-value+ 3)
+
+ (+opcode-call+ 2)
+ (+opcode-proceed+ 1)))
(defun* opcode-name ((opcode opcode))
@@ -22,11 +33,27 @@
(eswitch (opcode)
(+opcode-get-structure+ "GET-STRUCTURE")
(+opcode-unify-variable+ "UNIFY-VARIABLE")
- (+opcode-unify-value+ "UNIFY-VALUE")))
+ (+opcode-unify-value+ "UNIFY-VALUE")
+ (+opcode-get-variable+ "GET-VARIABLE")
+ (+opcode-get-value+ "GET-VALUE")
+
+ (+opcode-put-structure+ "PUT-STRUCTURE")
+ (+opcode-set-variable+ "SET-VARIABLE")
+ (+opcode-set-value+ "SET-VALUE")
+ (+opcode-put-variable+ "PUT-VARIABLE")
+ (+opcode-put-value+ "PUT-VALUE")))
(defun* opcode-short-name ((opcode opcode))
(:returns string)
(eswitch (opcode)
(+opcode-get-structure+ "GETS")
(+opcode-unify-variable+ "UVAR")
- (+opcode-unify-value+ "UVLU")))
+ (+opcode-unify-value+ "UVLU")
+ (+opcode-get-variable+ "GVAR")
+ (+opcode-get-value+ "GVLU")
+
+ (+opcode-put-structure+ "PUTS")
+ (+opcode-set-variable+ "SVAR")
+ (+opcode-set-value+ "SVLU")
+ (+opcode-put-variable+ "PVAR")
+ (+opcode-put-value+ "PVLU")))
--- a/src/wam/types.lisp Fri Apr 01 17:24:39 2016 +0000
+++ b/src/wam/types.lisp Fri Apr 01 19:16:23 2016 +0000
@@ -31,4 +31,4 @@
`(integer 0 ,(1- +code-limit+)))
(deftype opcode ()
- '(integer 0 3))
+ '(integer 0 12))
--- a/src/wam/wam.lisp Fri Apr 01 17:24:39 2016 +0000
+++ b/src/wam/wam.lisp Fri Apr 01 19:16:23 2016 +0000
@@ -95,6 +95,15 @@
;;;; Code
+(defun* retrieve-instruction (code-store (address code-index))
+ "Return the full instruction at the given address in the code store."
+ (make-array (instruction-size (aref code-store address))
+ :displaced-to code-store
+ :displaced-index-offset address
+ :adjustable nil
+ :element-type 'code-word))
+
+
(defun* wam-code-word ((wam wam) (address code-index))
(:returns code-word)
"Return the word at the given address in the code store."
@@ -106,11 +115,7 @@
(defun* wam-code-instruction ((wam wam) (address code-index))
"Return the full instruction at the given address in the code store."
- (make-array (instruction-size (wam-code-word wam address))
- :displaced-to (wam-code wam)
- :displaced-index-offset address
- :adjustable nil
- :element-type 'code-word))
+ (retrieve-instruction (wam-code wam) address))
(defun* wam-code-push-word! ((wam wam) (word code-word))