--- a/.lispwords Sat Apr 16 13:50:36 2016 +0000
+++ b/.lispwords Sun Apr 17 21:36:15 2016 +0000
@@ -1,2 +1,3 @@
(2 code-push-instruction!)
(1 repeat)
+(2 define-instruction define-instructions)
--- a/src/wam/bytecode.lisp Sat Apr 16 13:50:36 2016 +0000
+++ b/src/wam/bytecode.lisp Sun Apr 17 21:36:15 2016 +0000
@@ -9,17 +9,27 @@
"
(eswitch (opcode)
- (+opcode-get-structure+ 3)
- (+opcode-unify-variable+ 2)
- (+opcode-unify-value+ 2)
- (+opcode-get-variable+ 3)
- (+opcode-get-value+ 3)
+ (+opcode-get-structure-local+ 3)
+ (+opcode-get-structure-stack+ 3)
+ (+opcode-unify-variable-local+ 2)
+ (+opcode-unify-variable-stack+ 2)
+ (+opcode-unify-value-local+ 2)
+ (+opcode-unify-value-stack+ 2)
+ (+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-set-variable+ 2)
- (+opcode-set-value+ 2)
- (+opcode-put-variable+ 3)
- (+opcode-put-value+ 3)
+ (+opcode-put-structure-local+ 3)
+ (+opcode-put-structure-stack+ 3)
+ (+opcode-set-variable-local+ 2)
+ (+opcode-set-variable-stack+ 2)
+ (+opcode-set-value-local+ 2)
+ (+opcode-set-value-stack+ 2)
+ (+opcode-put-variable-local+ 3)
+ (+opcode-put-variable-stack+ 3)
+ (+opcode-put-value-local+ 3)
+ (+opcode-put-value-stack+ 3)
(+opcode-call+ 2)
(+opcode-proceed+ 1)
@@ -30,17 +40,27 @@
(defun* opcode-name ((opcode opcode))
(:returns string)
(eswitch (opcode)
- (+opcode-get-structure+ "GET-STRUCTURE")
- (+opcode-unify-variable+ "UNIFY-VARIABLE")
- (+opcode-unify-value+ "UNIFY-VALUE")
- (+opcode-get-variable+ "GET-VARIABLE")
- (+opcode-get-value+ "GET-VALUE")
+ (+opcode-get-structure-local+ "GET-STRUCTURE")
+ (+opcode-get-structure-stack+ "GET-STRUCTURE")
+ (+opcode-unify-variable-local+ "UNIFY-VARIABLE")
+ (+opcode-unify-variable-stack+ "UNIFY-VARIABLE")
+ (+opcode-unify-value-local+ "UNIFY-VALUE")
+ (+opcode-unify-value-stack+ "UNIFY-VALUE")
+ (+opcode-get-variable-local+ "GET-VARIABLE")
+ (+opcode-get-variable-stack+ "GET-VARIABLE")
+ (+opcode-get-value-local+ "GET-VALUE")
+ (+opcode-get-value-stack+ "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")
+ (+opcode-put-structure-local+ "PUT-STRUCTURE")
+ (+opcode-put-structure-stack+ "PUT-STRUCTURE")
+ (+opcode-set-variable-local+ "SET-VARIABLE")
+ (+opcode-set-variable-stack+ "SET-VARIABLE")
+ (+opcode-set-value-local+ "SET-VALUE")
+ (+opcode-set-value-stack+ "SET-VALUE")
+ (+opcode-put-variable-local+ "PUT-VARIABLE")
+ (+opcode-put-variable-stack+ "PUT-VARIABLE")
+ (+opcode-put-value-local+ "PUT-VALUE")
+ (+opcode-put-value-stack+ "PUT-VALUE")
(+opcode-call+ "CALL")
(+opcode-proceed+ "PROCEED")
@@ -50,76 +70,30 @@
(defun* opcode-short-name ((opcode opcode))
(:returns string)
(eswitch (opcode)
- (+opcode-get-structure+ "GETS")
- (+opcode-unify-variable+ "UVAR")
- (+opcode-unify-value+ "UVLU")
- (+opcode-get-variable+ "GVAR")
- (+opcode-get-value+ "GVLU")
+ (+opcode-get-structure-local+ "GETS")
+ (+opcode-get-structure-stack+ "GETS")
+ (+opcode-unify-variable-local+ "UVAR")
+ (+opcode-unify-variable-stack+ "UVAR")
+ (+opcode-unify-value-local+ "UVLU")
+ (+opcode-unify-value-stack+ "UVLU")
+ (+opcode-get-variable-local+ "GVAR")
+ (+opcode-get-variable-stack+ "GVAR")
+ (+opcode-get-value-local+ "GVLU")
+ (+opcode-get-value-stack+ "GVLU")
- (+opcode-put-structure+ "PUTS")
- (+opcode-set-variable+ "SVAR")
- (+opcode-set-value+ "SVLU")
- (+opcode-put-variable+ "PVAR")
- (+opcode-put-value+ "PVLU")
+ (+opcode-put-structure-local+ "PUTS")
+ (+opcode-put-structure-stack+ "PUTS")
+ (+opcode-set-variable-local+ "SVAR")
+ (+opcode-set-variable-stack+ "SVAR")
+ (+opcode-set-value-local+ "SVLU")
+ (+opcode-set-value-stack+ "SVLU")
+ (+opcode-put-variable-local+ "PVAR")
+ (+opcode-put-variable-stack+ "PVAR")
+ (+opcode-put-value-local+ "PVLU")
+ (+opcode-put-value-stack+ "PVLU")
(+opcode-call+ "CALL")
(+opcode-proceed+ "PROC")
(+opcode-allocate+ "ALOC")
(+opcode-deallocate+ "DEAL")))
-
-;;;; Register Designators
-;;; A register designator is a number that specifies a particular register.
-;;;
-;;; The register might be a local register (A_n or X_n in WAMspeak) for holding
-;;; temporary things or a stack register (Y_n) for holding permanent variables.
-;;;
-;;; Internally register designators are implemented as a bitmasked value/tag:
-;;;
-;;; value tag bit
-;;; rrrrrrrrrrrrrrrT
-;;;
-;;; But you should probably just use this interface to interact with them.
-
-(defun* register-designator-tag ((register-designator register-designator))
- (:returns register-designator-tag)
- (logand register-designator +register-designator-tag-bitmask+))
-
-(defun* register-designator-value ((register-designator register-designator))
- (:returns register-index)
- (ash register-designator -1))
-
-
-(defun* register-designator-local-p ((register-designator register-designator))
- (:returns boolean)
- (= +tag-local-register+
- (register-designator-tag register-designator)))
-
-(defun* register-designator-stack-p ((register-designator register-designator))
- (:returns boolean)
- (= +tag-stack-register+
- (register-designator-tag register-designator)))
-
-
-(defun* make-register-designator ((register register-index)
- (tag register-designator-tag))
- (:returns register-designator)
- (logior (ash register 1)
- tag))
-
-(defun* make-local-register-designator ((register register-index))
- (:returns register-designator)
- (make-register-designator register +tag-local-register+))
-
-(defun* make-stack-register-designator ((register register-index))
- (:returns register-designator)
- (make-register-designator register +tag-stack-register+))
-
-(defun* register-designator-to-string ((register-designator register-designator))
- (format nil
- (if (register-designator-local-p register-designator)
- ;; Unfortunately we've lost the X/A distinction by this point.
- "X~D"
- "Y~D")
- (+ (register-designator-value register-designator)
- (if *off-by-one* 1 0))))
--- a/src/wam/compiler.lisp Sat Apr 16 13:50:36 2016 +0000
+++ b/src/wam/compiler.lisp Sun Apr 17 21:36:15 2016 +0000
@@ -35,13 +35,6 @@
(make-register :permanent number))
-(defun* register-to-designator ((register register))
- (:returns register-designator)
- (with-slots (type number) register
- (if (eql type :permanent)
- (make-stack-register-designator number)
- (make-local-register-designator number))))
-
(defun* register-to-string ((register register))
(format nil "~A~D"
(ecase (register-type register)
@@ -56,6 +49,13 @@
(format stream (register-to-string object))))
+(defun* register-temporary-p ((register register))
+ (member (register-type register) '(:argument :local)))
+
+(defun* register-permanent-p ((register register))
+ (eql (register-type register) :permanent))
+
+
(defun* register= ((r1 register) (r2 register))
(:returns boolean)
(ensure-boolean
@@ -71,8 +71,8 @@
(register-type r2))
;; local and argument registers are actually the same register,
;; just named differently
- (and (member (register-type r1) '(:local :argument))
- (member (register-type r2) '(:local :argument))))
+ (and (register-temporary-p r1)
+ (register-temporary-p r2)))
(= (register-number r1)
(register-number r2)))))
@@ -161,7 +161,9 @@
;;; A1 -> q(A1, X3)
;;; X2 -> B
-(defun parse-term (term permanent-variables)
+(defun parse-term (term permanent-variables
+ ;; JESUS TAKE THE WHEEL
+ &optional reserved-variables reserved-arity)
"Parse a term into a series of register assignments.
Returns:
@@ -171,25 +173,15 @@
* The root functor's arity
"
- ;; A term is a Lispy representation of the raw Prolog. A register assignment
- ;; is a cons of (register . assigned-to), e.g.:
- ;;
- ;; (p :foo (f :foo :bar))
- ;; ->
- ;; (0 . 2) ; A0 = X2
- ;; (1 . 4) ; A1 = X3
- ;; (2 . :foo) ; X2 = Foo
- ;; (3 . (f 2 4)) ; X3 = f(X2, X4)
- ;; (4 . :bar) ; X4 = Bar
(let* ((predicate (first term))
(arguments (rest term))
(arity (length arguments))
;; Preallocate enough registers for all of the arguments. We'll fill
;; them in later.
(local-registers (make-array 64
- :fill-pointer arity
- :adjustable t
- :initial-element nil))
+ :fill-pointer (or reserved-arity arity)
+ :adjustable t
+ :initial-element nil))
;; We essentially "preallocate" all the permanent variables up front
;; because we need them to always be in the same stack registers across
;; all the terms of our clause.
@@ -197,7 +189,10 @@
;; The ones that won't get used in this term will end up getting
;; flattened away anyway.
(stack-registers (make-array (length permanent-variables)
- :initial-contents permanent-variables)))
+ :initial-contents permanent-variables)))
+ ;; TODO: document this clusterfuck
+ (loop :for variable :in reserved-variables :do
+ (vector-push-extend variable local-registers))
(labels
((find-variable (var)
(let ((r (position var local-registers))
@@ -234,7 +229,7 @@
(make-assignment-list (registers register-maker)
(loop :for i :from 0
:for contents :across registers
- :collect
+ :when contents :collect ; don't include unused reserved regs
(cons (funcall register-maker i arity)
contents))))
;; Arguments are handled specially. We parse the children as normal,
@@ -356,23 +351,34 @@
assignments))
-(defun tokenize-term (term permanent-variables flattener)
+(defun tokenize-term
+ (term permanent-variables reserved-variables reserved-arity flattener)
(multiple-value-bind (assignments functor arity)
- (parse-term term permanent-variables)
+ (parse-term term permanent-variables reserved-variables reserved-arity)
(values (->> assignments
(funcall flattener)
tokenize-assignments)
functor
arity)))
-(defun tokenize-program-term (term permanent-variables)
+(defun tokenize-program-term
+ (term permanent-variables reserved-variables reserved-arity)
"Tokenize `term` as a program term, returning its tokens, functor, and arity."
- (tokenize-term term permanent-variables #'flatten-program))
+ (tokenize-term term
+ permanent-variables
+ reserved-variables
+ reserved-arity
+ #'flatten-program))
-(defun tokenize-query-term (term permanent-variables)
+(defun tokenize-query-term
+ (term permanent-variables &optional reserved-variables reserved-arity)
"Tokenize `term` as a query term, returning its stream of tokens."
(multiple-value-bind (tokens functor arity)
- (tokenize-term term permanent-variables #'flatten-query)
+ (tokenize-term term
+ permanent-variables
+ reserved-variables
+ reserved-arity
+ #'flatten-query)
;; We need to shove a CALL token onto the end.
(append tokens `((:call ,functor ,arity)))))
@@ -394,6 +400,35 @@
;;; (#'%set-value 1)
;;; (#'%set-value 2)
+(defun find-opcode (opcode newp mode &optional register)
+ (flet ((find-variant (register)
+ (when register
+ (if (register-temporary-p register)
+ :local
+ :stack))))
+ (eswitch ((list opcode newp mode (find-variant register)) :test #'equal)
+ ('(:argument t :program :local) +opcode-get-variable-local+)
+ ('(:argument t :program :stack) +opcode-get-variable-stack+)
+ ('(:argument t :query :local) +opcode-put-variable-local+)
+ ('(:argument t :query :stack) +opcode-put-variable-stack+)
+ ('(:argument nil :program :local) +opcode-get-value-local+)
+ ('(:argument nil :program :stack) +opcode-get-value-stack+)
+ ('(:argument nil :query :local) +opcode-put-value-local+)
+ ('(:argument nil :query :stack) +opcode-put-value-stack+)
+ ('(:structure nil :program :local) +opcode-get-structure-local+)
+ ('(:structure nil :program :stack) +opcode-get-structure-stack+)
+ ('(:structure nil :query :local) +opcode-put-structure-local+)
+ ('(:structure nil :query :stack) +opcode-put-structure-stack+)
+ ('(:register t :program :local) +opcode-unify-variable-local+)
+ ('(:register t :program :stack) +opcode-unify-variable-stack+)
+ ('(:register t :query :local) +opcode-set-variable-local+)
+ ('(:register t :query :stack) +opcode-set-variable-stack+)
+ ('(:register nil :program :local) +opcode-unify-value-local+)
+ ('(:register nil :program :stack) +opcode-unify-value-stack+)
+ ('(:register nil :query :local) +opcode-set-value-local+)
+ ('(: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.
@@ -413,25 +448,18 @@
(labels
((handle-argument (argument-register source-register)
;; OP X_n A_i
- (code-push-instruction! store
- (if (push-if-new source-register seen :test #'register=)
- (ecase mode
- (:program +opcode-get-variable+)
- (:query +opcode-put-variable+))
- (ecase mode
- (:program +opcode-get-value+)
- (:query +opcode-put-value+)))
- (register-to-designator source-register)
- (register-to-designator argument-register)))
+ (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
- (ecase mode
- (:program +opcode-get-structure+)
- (:query +opcode-put-structure+))
+ (find-opcode :structure nil mode destination-register)
(wam-ensure-functor-index wam (cons functor arity))
- (register-to-designator destination-register)))
+ (register-number destination-register)))
(handle-call (functor arity)
;; CALL functor
(code-push-instruction! store
@@ -439,15 +467,10 @@
(wam-ensure-functor-index wam (cons functor arity))))
(handle-register (register)
;; OP reg
- (code-push-instruction! store
- (if (push-if-new register seen :test #'register=)
- (ecase mode
- (:program +opcode-unify-variable+)
- (:query +opcode-set-variable+))
- (ecase mode
- (:program +opcode-unify-value+)
- (:query +opcode-set-value+)))
- (register-to-designator register)))
+ (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
@@ -473,6 +496,16 @@
;;;; UI
+(defun find-shared-variables (terms)
+ "Return a list of all variables shared by two or more terms."
+ (let* ((variables (remove-duplicates (tree-collect #'variable-p terms))))
+ (flet ((permanent-p (variable)
+ "Permanent variables are those contained in more than 1 term."
+ (> (count-if (curry #'tree-member-p variable)
+ terms)
+ 1)))
+ (remove-if-not #'permanent-p variables))))
+
(defun find-permanent-variables (clause)
"Return a list of all the 'permanent' variables in `clause`.
@@ -480,19 +513,19 @@
where the head of the clause is considered to be a part of the first goal.
"
- (if (< (length clause) 2)
+ (if (<= (length clause) 2)
(list) ; facts and chain rules have no permanent variables at all
(destructuring-bind (head body-first . body-rest) clause
;; the head is treated as part of the first goal for the purposes of
;; finding permanent variables
- (let* ((goals (cons (cons head body-first) body-rest))
- (variables (remove-duplicates (tree-collect #'variable-p goals))))
- (flet ((permanent-p (variable)
- "Permanent variables are those contained in more than 1 goal."
- (> (count-if (curry #'tree-member-p variable)
- goals)
- 1)))
- (remove-if-not #'permanent-p variables))))))
+ (find-shared-variables (cons (cons head body-first) body-rest)))))
+
+(defun find-head-variables (clause)
+ (if (<= (length clause) 1)
+ (list)
+ (destructuring-bind (head body-first . body-rest) clause
+ (declare (ignore body-rest))
+ (find-shared-variables (list head body-first)))))
(defun mark-label (wam functor arity store)
@@ -504,9 +537,9 @@
(defun make-query-code-store ()
(make-array 64
- :fill-pointer 0
- :adjustable t
- :element-type 'code-word))
+ :fill-pointer 0
+ :adjustable t
+ :element-type 'code-word))
(defun compile-clause (wam store head body)
@@ -518,15 +551,31 @@
"
(let* ((permanent-variables
(find-permanent-variables (cons head body)))
+ (head-variables
+ (set-difference (find-head-variables (cons head body))
+ permanent-variables))
+ (head-arity
+ (max (1- (length head))
+ (1- (length (car body)))))
(head-tokens
(when head
(multiple-value-bind (tokens functor arity)
- (tokenize-program-term head permanent-variables)
+ (tokenize-program-term head
+ permanent-variables
+ head-variables
+ head-arity)
(mark-label wam functor arity store) ; TODO: this is ugly
tokens)))
(body-tokens
- (loop :for term :in body :append
- (tokenize-query-term term permanent-variables))))
+ (when body
+ (append
+ (tokenize-query-term (first body)
+ permanent-variables
+ head-variables
+ head-arity)
+ (loop :for term :in (rest body) :append
+ (tokenize-query-term term
+ permanent-variables))))))
(flet ((compile% () (compile-tokens wam head-tokens body-tokens store)))
;; We need to compile facts and rules differently. Facts end with
;; a PROCEED and rules are wrapped in ALOC/DEAL.
--- a/src/wam/constants.lisp Sat Apr 16 13:50:36 2016 +0000
+++ b/src/wam/constants.lisp Sun Apr 17 21:36:15 2016 +0000
@@ -66,9 +66,6 @@
(define-constant +tag-stack-register+ #b1
:documentation "A stack register (Y_n).")
-(define-constant +register-designator-tag-bitmask+ #b1
- :documentation "Bitmask for the type tag of a register designator.")
-
(define-constant +stack-word-size+ 16
:documentation "Size (in bits) of each word in WAM stack.")
@@ -88,26 +85,36 @@
;;;; 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)
+(define-constant +opcode-get-structure-local+ 0)
+(define-constant +opcode-get-structure-stack+ 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+ 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)
+(define-constant +opcode-put-structure-local+ 10)
+(define-constant +opcode-put-structure-stack+ 11)
+(define-constant +opcode-set-variable-local+ 12)
+(define-constant +opcode-set-variable-stack+ 13)
+(define-constant +opcode-set-value-local+ 14)
+(define-constant +opcode-set-value-stack+ 15)
+(define-constant +opcode-put-variable-local+ 16)
+(define-constant +opcode-put-variable-stack+ 17)
+(define-constant +opcode-put-value-local+ 18)
+(define-constant +opcode-put-value-stack+ 19)
;;; Control
-(define-constant +opcode-call+ 11)
-(define-constant +opcode-proceed+ 12)
-(define-constant +opcode-allocate+ 13)
-(define-constant +opcode-deallocate+ 14)
+(define-constant +opcode-call+ 20)
+(define-constant +opcode-proceed+ 21)
+(define-constant +opcode-allocate+ 22)
+(define-constant +opcode-deallocate+ 23)
;;;; Debug Config
--- a/src/wam/dump.lisp Sat Apr 16 13:50:36 2016 +0000
+++ b/src/wam/dump.lisp Sun Apr 17 21:36:15 2016 +0000
@@ -117,52 +117,98 @@
(pretty-arguments arguments)))
-(defmethod instruction-details ((opcode (eql +opcode-set-variable+)) arguments functor-list)
- (format nil "SVAR~A ; ~A <- new unbound REF"
+(defmethod instruction-details ((opcode (eql +opcode-set-variable-local+)) arguments functor-list)
+ (format nil "SVAR~A ; X~A <- new unbound REF"
(pretty-arguments arguments)
- (register-designator-to-string (first arguments))))
+ (first arguments)))
+
+(defmethod instruction-details ((opcode (eql +opcode-set-variable-stack+)) arguments functor-list)
+ (format nil "SVAR~A ; Y~A <- new unbound REF"
+ (pretty-arguments arguments)
+ (first arguments)))
-(defmethod instruction-details ((opcode (eql +opcode-set-value+)) arguments functor-list)
- (format nil "SVLU~A ; new REF to ~A"
+(defmethod instruction-details ((opcode (eql +opcode-set-value-local+)) arguments functor-list)
+ (format nil "SVLU~A ; new REF to X~A"
(pretty-arguments arguments)
- (register-designator-to-string (first arguments))))
+ (first arguments)))
-(defmethod instruction-details ((opcode (eql +opcode-get-structure+)) arguments functor-list)
- (format nil "GETS~A ; ~A = ~A"
+(defmethod instruction-details ((opcode (eql +opcode-set-value-stack+)) arguments functor-list)
+ (format nil "SVLU~A ; new REF to Y~A"
(pretty-arguments arguments)
- (register-designator-to-string (second arguments))
+ (first arguments)))
+
+(defmethod instruction-details ((opcode (eql +opcode-get-structure-local+)) arguments functor-list)
+ (format nil "GETS~A ; X~A = ~A"
+ (pretty-arguments arguments)
+ (second arguments)
(pretty-functor (first arguments) functor-list)))
-(defmethod instruction-details ((opcode (eql +opcode-put-structure+)) arguments functor-list)
- (format nil "PUTS~A ; ~A <- new ~A"
+(defmethod instruction-details ((opcode (eql +opcode-get-structure-stack+)) arguments functor-list)
+ (format nil "GETS~A ; Y~A = ~A"
(pretty-arguments arguments)
- (register-designator-to-string (second arguments))
+ (second arguments)
+ (pretty-functor (first arguments) functor-list)))
+
+(defmethod instruction-details ((opcode (eql +opcode-put-structure-local+)) arguments functor-list)
+ (format nil "PUTS~A ; X~A <- new ~A"
+ (pretty-arguments arguments)
+ (second arguments)
+ (pretty-functor (first arguments) functor-list)))
+
+(defmethod instruction-details ((opcode (eql +opcode-put-structure-stack+)) arguments functor-list)
+ (format nil "PUTS~A ; Y~A <- new ~A"
+ (pretty-arguments arguments)
+ (second arguments)
(pretty-functor (first arguments) functor-list)))
-(defmethod instruction-details ((opcode (eql +opcode-get-variable+)) arguments functor-list)
- (format nil "GVAR~A ; ~A <- ~A"
+(defmethod instruction-details ((opcode (eql +opcode-get-variable-local+)) arguments functor-list)
+ (format nil "GVAR~A ; X~A <- A~A"
(pretty-arguments arguments)
- (register-designator-to-string (first arguments))
- (register-designator-to-string (second arguments))))
+ (first arguments)
+ (second arguments)))
+
+(defmethod instruction-details ((opcode (eql +opcode-get-variable-stack+)) arguments functor-list)
+ (format nil "GVAR~A ; Y~A <- A~A"
+ (pretty-arguments arguments)
+ (first arguments)
+ (second arguments)))
-(defmethod instruction-details ((opcode (eql +opcode-get-value+)) arguments functor-list)
- (format nil "GVLU~A ; ~A = ~A"
+(defmethod instruction-details ((opcode (eql +opcode-get-value-local+)) arguments functor-list)
+ (format nil "GVLU~A ; X~A = A~A"
(pretty-arguments arguments)
- (register-designator-to-string (second arguments))
- (register-designator-to-string (first arguments))))
+ (first arguments)
+ (second arguments)))
+
+(defmethod instruction-details ((opcode (eql +opcode-get-value-stack+)) arguments functor-list)
+ (format nil "GVLU~A ; Y~A = A~A"
+ (pretty-arguments arguments)
+ (first arguments)
+ (second arguments)))
-(defmethod instruction-details ((opcode (eql +opcode-put-variable+)) arguments functor-list)
- (format nil "PVAR~A ; ~A <- ~A <- new unbound REF"
+(defmethod instruction-details ((opcode (eql +opcode-put-variable-local+)) arguments functor-list)
+ (format nil "PVAR~A ; X~A <- A~A <- new unbound REF"
(pretty-arguments arguments)
- (register-designator-to-string (second arguments))
- (register-designator-to-string (first arguments))))
+ (first arguments)
+ (second arguments)))
+
+(defmethod instruction-details ((opcode (eql +opcode-put-variable-stack+)) arguments functor-list)
+ (format nil "PVAR~A ; Y~A <- A~A <- new unbound REF"
+ (pretty-arguments arguments)
+ (second arguments)
+ (first arguments)))
-(defmethod instruction-details ((opcode (eql +opcode-put-value+)) arguments functor-list)
- (format nil "PVLU~A ; ~A <- ~A"
+(defmethod instruction-details ((opcode (eql +opcode-put-value-local+)) arguments functor-list)
+ (format nil "PVLU~A ; A~A <- X~A"
(pretty-arguments arguments)
- (register-designator-to-string (second arguments))
- (register-designator-to-string (first arguments))))
+ (second arguments)
+ (first arguments)))
+
+(defmethod instruction-details ((opcode (eql +opcode-put-value-stack+)) arguments functor-list)
+ (format nil "PVLU~A ; A~A <- Y~A"
+ (pretty-arguments arguments)
+ (second arguments)
+ (first arguments)))
(defmethod instruction-details ((opcode (eql +opcode-call+)) arguments functor-list)
@@ -182,7 +228,11 @@
(when lbl
(format t ";;;; BEGIN ~A~%"
(pretty-functor lbl (wam-functors wam)))))
- (format t "; ~4,'0X: " addr)
+ (format t ";~A~4,'0X: "
+ (if (= (wam-program-counter wam) addr)
+ ">>"
+ " ")
+ addr)
(let ((instruction (retrieve-instruction code-store addr)))
(format t "~A~%" (instruction-details (aref instruction 0)
(rest (coerce instruction 'list))
--- a/src/wam/interpreter.lisp Sat Apr 16 13:50:36 2016 +0000
+++ b/src/wam/interpreter.lisp Sun Apr 17 21:36:15 2016 +0000
@@ -142,54 +142,73 @@
(fail! wam "Functors don't match in unify!")))))))))
+;;;; Instruction Definition
+(defmacro define-instruction (name lambda-list &body body)
+ `(defun* ,name ,lambda-list
+ (:returns :void)
+ ,@body
+ (values)))
+
+(defmacro define-instructions ((local-name stack-name) lambda-list &body body)
+ `(progn
+ (macrolet ((%wam-register% (wam register)
+ `(wam-local-register ,wam ,register)))
+ (define-instruction ,local-name ,lambda-list
+ ,@body))
+ (macrolet ((%wam-register% (wam register)
+ `(wam-stack-register ,wam ,register)))
+ (define-instruction ,stack-name ,lambda-list
+ ,@body))))
+
+
;;;; Query Instructions
-(defun* %put-structure ((wam wam)
- (functor functor-index)
- (register register-designator))
- (:returns :void)
+(define-instructions (%put-structure-local %put-structure-stack)
+ ((wam wam)
+ (functor functor-index)
+ (register register-index))
(->> (push-new-structure! wam)
(nth-value 1)
- (setf (wam-register wam register)))
- (push-new-functor! wam functor)
- (values))
+ (setf (%wam-register% wam register)))
+ (push-new-functor! wam functor))
-(defun* %set-variable ((wam wam) (register register-designator))
- (:returns :void)
+(define-instructions (%set-variable-local %set-variable-stack)
+ ((wam wam)
+ (register register-index))
(->> (push-unbound-reference! wam)
(nth-value 1)
- (setf (wam-register wam register)))
- (values))
+ (setf (%wam-register% wam register))))
-(defun* %set-value ((wam wam) (register register-designator))
- (:returns :void)
- (wam-heap-push! wam (wam-register-cell wam register))
- (values))
+(define-instructions (%set-value-local %set-value-stack)
+ ((wam wam)
+ (register register-index))
+ (wam-heap-push! wam (->> register
+ (%wam-register% wam)
+ (wam-heap-cell wam))))
-(defun* %put-variable ((wam wam)
- (register register-designator)
- (argument register-designator))
- (:returns :void)
+(define-instructions (%put-variable-local %put-variable-stack)
+ ((wam wam)
+ (register register-index)
+ (argument register-index))
(->> (push-unbound-reference! wam)
(nth-value 1)
- (setf (wam-register wam register))
- (setf (wam-register wam argument)))
- (values))
+ (setf (%wam-register% wam register))
+ (setf (wam-local-register wam argument))))
-(defun* %put-value ((wam wam)
- (register register-designator)
- (argument register-designator))
- (:returns :void)
- (setf (wam-register wam argument)
- (wam-register wam register))
- (values))
+(define-instructions (%put-value-local %put-value-stack)
+ ((wam wam)
+ (register register-index)
+ (argument register-index))
+ (setf (wam-local-register wam argument)
+ (%wam-register% wam register)))
;;;; Program Instructions
-(defun* %get-structure ((wam wam)
- (functor functor-index)
- (register register-designator))
- (:returns :void)
- (let* ((addr (deref wam (wam-register wam register)))
+;; TODO: do we really need both of these variants?
+(define-instructions (%get-structure-local %get-structure-stack)
+ ((wam wam)
+ (functor functor-index)
+ (register register-index))
+ (let* ((addr (deref wam (%wam-register% wam register)))
(cell (wam-heap-cell wam addr)))
(cond
;; If the register points at a reference cell, we push two new cells onto
@@ -236,51 +255,50 @@
(setf (wam-mode wam) :read))
(fail! wam "Functors don't match in get-struct"))))
(t (fail! wam (format nil "get-struct on a non-ref/struct cell ~A"
- (cell-aesthetic cell))))))
- (values))
+ (cell-aesthetic cell)))))))
-(defun* %unify-variable ((wam wam) (register register-designator))
- (:returns :void)
+(define-instructions (%unify-variable-local %unify-variable-stack)
+ ((wam wam)
+ (register register-index))
(ecase (wam-mode wam)
- (:read (setf (wam-register wam register)
+ (:read (setf (%wam-register% wam register)
(wam-s wam)))
(:write (->> (push-unbound-reference! wam)
(nth-value 1)
- (setf (wam-register wam register)))))
- (incf (wam-s wam))
- (values))
+ (setf (%wam-register% wam register)))))
+ (incf (wam-s wam)))
-(defun* %unify-value ((wam wam) (register register-designator))
- (:returns :void)
+(define-instructions (%unify-value-local %unify-value-stack)
+ ((wam wam)
+ (register register-index))
(ecase (wam-mode wam)
(:read (unify! wam
- (wam-register wam register)
+ (%wam-register% wam register)
(wam-s wam)))
- (:write (wam-heap-push! wam (wam-register-cell wam register))))
- (incf (wam-s wam))
- (values))
+ (:write (wam-heap-push! wam
+ (->> register
+ (%wam-register% wam)
+ (wam-heap-cell wam)))))
+ (incf (wam-s wam)))
-(defun* %get-variable ((wam wam)
- (register register-designator)
- (argument register-designator))
- (:returns :void)
- (setf (wam-register wam register)
- (wam-register wam argument))
- (values))
+(define-instructions (%get-variable-local %get-variable-stack)
+ ((wam wam)
+ (register register-index)
+ (argument register-index))
+ (setf (%wam-register% wam register)
+ (wam-local-register wam argument)))
-(defun* %get-value ((wam wam)
- (register register-designator)
- (argument register-designator))
- (:returns :void)
+(define-instructions (%get-value-local %get-value-stack)
+ ((wam wam)
+ (register register-index)
+ (argument register-index))
(unify! wam
- (wam-register wam register)
- (wam-register wam argument))
- (values))
+ (%wam-register% wam register)
+ (wam-local-register wam argument)))
;;;; Control Instructions
-(defun* %call ((wam wam) (functor functor-index))
- (:returns :void)
+(define-instruction %call ((wam wam) (functor functor-index))
(let ((target (wam-code-label wam functor)))
(if target
(progn
@@ -289,17 +307,13 @@
(instruction-size +opcode-call+))
(wam-program-counter wam) ; PC <- target
target))
- (fail! wam "Tried to call unknown procedure.")))
- (values))
+ (fail! wam "Tried to call unknown procedure."))))
-(defun* %proceed ((wam wam))
- (:returns :void)
+(define-instruction %proceed ((wam wam))
(setf (wam-program-counter wam) ; P <- CP
- (wam-continuation-pointer wam))
- (values))
+ (wam-continuation-pointer wam)))
-(defun* %allocate ((wam wam) (n stack-frame-argcount))
- (:returns :void)
+(define-instruction %allocate ((wam wam) (n stack-frame-argcount))
(setf (wam-environment-pointer wam) ; E <- new E
(->> wam
wam-environment-pointer
@@ -309,8 +323,7 @@
(wam-stack-push! wam n) ; N
(wam-stack-extend! wam n)) ; Y_n (TODO: this sucks)
-(defun* %deallocate ((wam wam))
- (:returns :void)
+(define-instruction %deallocate ((wam wam))
(setf (wam-program-counter wam)
(wam-stack-frame-cp wam))
(wam-stack-pop-environment! wam))
@@ -358,41 +371,52 @@
(defun run-program (wam functor &optional (step nil))
(with-slots (code program-counter fail) wam
- (setf program-counter (wam-code-label wam functor))
- (loop
- :while (and (not fail) ; failure
- (not (= program-counter +code-sentinal+))) ; finished
- :for opcode = (aref code program-counter)
- :do
- (block op
- (when step
- (break "About to execute instruction at ~4,'0X" program-counter))
- (eswitch (opcode)
- ;; Query
- (+opcode-put-structure+ (instruction-call wam %put-structure code program-counter 2))
- (+opcode-set-variable+ (instruction-call wam %set-variable code program-counter 1))
- (+opcode-set-value+ (instruction-call wam %set-value code program-counter 1))
- (+opcode-put-variable+ (instruction-call wam %put-variable code program-counter 2))
- (+opcode-put-value+ (instruction-call wam %put-value code program-counter 2))
- ;; Program
- (+opcode-get-structure+ (instruction-call wam %get-structure code program-counter 2))
- (+opcode-unify-variable+ (instruction-call wam %unify-variable code program-counter 1))
- (+opcode-unify-value+ (instruction-call wam %unify-value code program-counter 1))
- (+opcode-get-variable+ (instruction-call wam %get-variable code program-counter 2))
- (+opcode-get-value+ (instruction-call wam %get-value code program-counter 2))
- ;; Control
- (+opcode-allocate+ (instruction-call wam %allocate code program-counter 1))
- ;; need to skip the PC increment for PROC/CALL/DEAL
- ;; TODO: this is ugly
- (+opcode-deallocate+ (instruction-call wam %deallocate code program-counter 0)
- (return-from op))
- (+opcode-proceed+ (instruction-call wam %proceed code program-counter 0)
- (return-from op))
- (+opcode-call+ (instruction-call wam %call code program-counter 1)
- (return-from op)))
- (incf program-counter (instruction-size opcode))
- (when (>= program-counter (fill-pointer code))
- (error "Fell off the end of the program code store!"))))
+ (macrolet ((instruction (inst args &body body)
+ `(progn
+ (instruction-call wam ,inst code program-counter ,args)
+ ,@body)))
+ (setf program-counter (wam-code-label wam functor))
+ (loop
+ :while (and (not fail) ; failure
+ (not (= program-counter +code-sentinal+))) ; finished
+ :for opcode = (aref code program-counter)
+ :do
+ (block op
+ (when step
+ (break "About to execute instruction at ~4,'0X" program-counter))
+ (eswitch (opcode)
+ ;; Query
+ (+opcode-put-structure-local+ (instruction %put-structure-local 2))
+ (+opcode-put-structure-stack+ (instruction %put-structure-stack 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))
+ ;; Program
+ (+opcode-get-structure-local+ (instruction %get-structure-local 2))
+ (+opcode-get-structure-stack+ (instruction %get-structure-stack 2))
+ (+opcode-unify-variable-local+ (instruction %unify-variable-local 1))
+ (+opcode-unify-variable-stack+ (instruction %unify-variable-stack 1))
+ (+opcode-unify-value-local+ (instruction %unify-value-local 1))
+ (+opcode-unify-value-stack+ (instruction %unify-value-stack 1))
+ (+opcode-get-variable-local+ (instruction %get-variable-local 2))
+ (+opcode-get-variable-stack+ (instruction %get-variable-stack 2))
+ (+opcode-get-value-local+ (instruction %get-value-local 2))
+ (+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
+ ;; 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))))
+ (incf program-counter (instruction-size opcode))
+ (when (>= program-counter (fill-pointer code))
+ (error "Fell off the end of the program code store!")))))
(values)))
(defun run-query (wam term &optional (step nil))
@@ -404,31 +428,42 @@
"
;; TODO: dedupe this interpreter code
- (let ((code (compile-query wam term)))
- (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+ (instruction-call wam %put-structure code pc 2))
- (+opcode-set-variable+ (instruction-call wam %set-variable code pc 1))
- (+opcode-set-value+ (instruction-call wam %set-value code pc 1))
- (+opcode-put-variable+ (instruction-call wam %put-variable code pc 2))
- (+opcode-put-value+ (instruction-call wam %put-value code pc 2))
- (+opcode-call+
- (when step (break))
- (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!")))))
+ (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-put-structure-stack+ (instruction %put-structure-stack 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!"))))))
(if (wam-fail wam)
(princ "No.")
- (loop :for (var . val) :in (extract-query-results wam (first term))
- :do (format t "~S -> ~S~%" var val)))
+ (princ "Yes."))
(values))
--- a/src/wam/types.lisp Sat Apr 16 13:50:36 2016 +0000
+++ b/src/wam/types.lisp Sun Apr 17 21:36:15 2016 +0000
@@ -39,16 +39,7 @@
(deftype opcode ()
- '(integer 0 14))
-
-
-(deftype register-designator ()
- 'code-word)
-
-(deftype register-designator-tag ()
- `(member
- ,+tag-stack-register+
- ,+tag-local-register+))
+ '(integer 0 23))
(deftype stack-frame-size ()
--- a/src/wam/ui.lisp Sat Apr 16 13:50:36 2016 +0000
+++ b/src/wam/ui.lisp Sun Apr 17 21:36:15 2016 +0000
@@ -2,20 +2,25 @@
(defparameter *database* nil)
+(defparameter *debug* nil)
(defmacro with-database (&body body)
`(let ((*database* (make-wam)))
,@body))
+
(defun add-rule (rule)
(compile-program *database* rule))
+(defun perform-query (query)
+ (run-query *database* query *debug*))
+
+
(defmacro rule (&body body)
`(add-rule ',body))
-(defun perform-query (query)
- (run-query *database* query))
-
(defmacro query (&body body)
`(perform-query ',body))
+(defun dump ()
+ (dump-wam-full *database*))
--- a/src/wam/wam.lisp Sat Apr 16 13:50:36 2016 +0000
+++ b/src/wam/wam.lisp Sun Apr 17 21:36:15 2016 +0000
@@ -4,25 +4,25 @@
(defclass wam ()
((heap
:initform (make-array 1024
- :fill-pointer 0
- :adjustable t
- :initial-element (make-cell-null)
- :element-type 'heap-cell)
+ :fill-pointer 0
+ :adjustable t
+ :initial-element (make-cell-null)
+ :element-type 'heap-cell)
:reader wam-heap
:documentation "The actual heap (stack).")
(code
:initform (make-array 1024
- :adjustable t
- :fill-pointer 0
- :initial-element 0
- :element-type 'code-word)
+ :adjustable t
+ :fill-pointer 0
+ :initial-element 0
+ :element-type 'code-word)
:reader wam-code
:documentation "The code store.")
(functors
:initform (make-array 64
- :fill-pointer 0
- :adjustable t
- :element-type 'functor)
+ :fill-pointer 0
+ :adjustable t
+ :element-type 'functor)
:accessor wam-functors
:documentation "The array of functors in this WAM.")
(code-labels
@@ -32,22 +32,20 @@
(registers
:reader wam-local-registers
:initform (make-array +register-count+
- ;; Initialize to the last element in the heap for
- ;; debugging purposes.
- ;; todo: don't do this
- :initial-element (1- +heap-limit+)
- :element-type 'heap-index)
+ ;; Initialize to the last element in the heap for debugging.
+ ;; todo: don't do this
+ :initial-element (1- +heap-limit+)
+ :element-type 'heap-index)
:documentation "An array of the local X_i registers.")
(stack
:reader wam-stack
:initform (make-array 1024
- :adjustable t
- :fill-pointer 0
- ;; Initialize to the last element in the heap for
- ;; debugging purposes.
- ;; todo: don't do this
- :initial-element (1- +heap-limit+)
- :element-type 'stack-word)
+ :adjustable t
+ :fill-pointer 0
+ ;; Initialize to the last element in the heap for debugging.
+ ;; todo: don't do this
+ :initial-element (1- +heap-limit+)
+ :element-type 'stack-word)
:documentation "The local stack for storing stack frames.")
(fail
:accessor wam-fail
@@ -57,9 +55,9 @@
(unification-stack
:reader wam-unification-stack
:initform (make-array 16
- :fill-pointer 0
- :adjustable t
- :element-type 'heap-index)
+ :fill-pointer 0
+ :adjustable t
+ :element-type 'heap-index)
:documentation "The unification stack.")
(s
:accessor wam-s
@@ -235,7 +233,7 @@
"Pop an environment (stack frame) off the WAM stack."
(let ((frame-size (wam-stack-frame-size wam)))
(with-slots (stack environment-pointer) wam
- (decf environment-pointer frame-size) ; lol
+ (setf environment-pointer (wam-stack-frame-ce wam)) ; E <- CE
(decf (fill-pointer stack) frame-size)))) ; its fine
@@ -267,10 +265,10 @@
(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))
+ :displaced-to code-store
+ :displaced-index-offset address
+ :adjustable nil
+ :element-type 'code-word))
(defun* wam-code-word ((wam wam) (address code-index))
@@ -338,12 +336,9 @@
;;;
;;; Registers are typically denoted by their "register index", which is just
;;; their number. Hoever, the bytecode needs to be able to distinguish between
-;;; local and stack registers. To do this we use "register designators" (see
-;;; bytecode.lisp for more information on those).
-;;;
-;;; `wam-register` and `wam-register-cell` provide an interface to pass in
-;;; a register designator and get out "the right thing", so you should probably
-;;; just use those and not worry about the other functions here.
+;;; local and stack registers. To do this we just make separate opcodes for
+;;; each kind. This is ugly, but it lets us figure things out at compile time
+;;; instead of runtime, and register references happen A LOT at runtime.
(defun* wam-local-register ((wam wam) (register register-index))
(:returns heap-index)
@@ -363,29 +358,6 @@
(setf (wam-stack-frame-arg wam register) new-value))
-(defun* wam-register ((wam wam) (register-designator register-designator))
- (:returns heap-index)
- "Return the heap index the designated register is pointing at."
- (if (register-designator-local-p register-designator) ; ugly but fast
- (wam-local-register wam (register-designator-value register-designator))
- (wam-stack-register wam (register-designator-value register-designator))))
-
-(defun (setf wam-register) (new-value wam register-designator)
- (if (register-designator-local-p register-designator) ; ugly but fast
- (setf (wam-local-register wam (register-designator-value register-designator)) new-value)
- (setf (wam-stack-register wam (register-designator-value register-designator)) new-value)))
-
-
-(defun* wam-register-cell ((wam wam) (register-designator register-designator))
- (:returns heap-cell)
- "Return the heap cell the designated register is pointing at."
- (wam-heap-cell
- wam
- (if (register-designator-local-p register-designator)
- (wam-local-register wam (register-designator-value register-designator))
- (wam-stack-register wam (register-designator-value register-designator)))))
-
-
(defun* wam-s-cell ((wam wam))
"Retrieve the cell the S register is pointing at.