--- a/bones.asd Thu Apr 14 17:16:20 2016 +0000
+++ b/bones.asd Fri Apr 15 20:28:35 2016 +0000
@@ -26,7 +26,7 @@
(:file "types")
(:file "topological-sort")
(:file "cells")
- (:file "opcodes")
+ (:file "bytecode")
(:file "wam")
(:file "compile")
(:file "instructions")
--- /dev/null Thu Jan 01 00:00:00 1970 +0000
+++ b/src/wam/bytecode.lisp Fri Apr 15 20:28:35 2016 +0000
@@ -0,0 +1,110 @@
+(in-package #:bones.wam)
+
+;;;; Opcodes
+(defun* instruction-size ((opcode opcode))
+ (: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+ 3)
+ (+opcode-unify-variable+ 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))
+ (: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-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-call+ "CALL")
+ (+opcode-proceed+ "PROCEED")))
+
+(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-put-structure+ "PUTS")
+ (+opcode-set-variable+ "SVAR")
+ (+opcode-set-value+ "SVLU")
+ (+opcode-put-variable+ "PVAR")
+ (+opcode-put-value+ "PVLU")
+
+ (+opcode-call+ "CALL")
+ (+opcode-proceed+ "PROC")))
+
+
+;;;; 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+))
--- a/src/wam/cells.lisp Thu Apr 14 17:16:20 2016 +0000
+++ b/src/wam/cells.lisp Fri Apr 15 20:28:35 2016 +0000
@@ -67,7 +67,7 @@
(+tag-structure+
(format nil " ~D" (cell-value cell)))
(+tag-functor+
- (format nil " functor ~D"
+ (format nil " ~D"
(cell-functor-index cell)))
(+tag-reference+
(format nil " ~D" (cell-value cell))))))
--- a/src/wam/compile.lisp Thu Apr 14 17:16:20 2016 +0000
+++ b/src/wam/compile.lisp Fri Apr 15 20:28:35 2016 +0000
@@ -71,7 +71,7 @@
(defun* pprint-assignments ((assignments register-assignment-list))
(format t "~{~A~%~}"
(loop :for (register . contents) :in assignments :collect
- (format nil "~A <- ~A" (register-to-string register) contents))))
+ (format nil "~A <- ~S" (register-to-string register) contents))))
(defun* find-assignment ((register register)
(assignments register-assignment-list))
@@ -143,7 +143,7 @@
;;; A1 -> q(A1, X3)
;;; X2 -> B
-(defun parse-term (term)
+(defun parse-term (term permanent-variables)
"Parse a term into a series of register assignments.
Returns:
@@ -168,30 +168,44 @@
(arity (length arguments))
;; Preallocate enough registers for all of the arguments.
;; We'll fill them in later.
- (registers (make-array 64
- :fill-pointer arity
- :adjustable t
- :initial-element nil)))
+ (local-registers (make-array 64
+ :fill-pointer arity
+ :adjustable t
+ :initial-element nil))
+ (stack-registers (make-array 64
+ :fill-pointer 0
+ :adjustable t
+ :initial-element nil)))
(labels
((make-temporary-register (number)
(make-register (if (< number arity) :argument :local)
number))
+ (make-permanent-register (number)
+ (make-register :permanent number))
(find-variable (var)
- (let ((r (position var registers)))
- (when r
- (make-temporary-register r))))
+ (let ((r (position var local-registers))
+ (s (position var stack-registers)))
+ (cond
+ (r (make-temporary-register r))
+ (s (make-permanent-register s))
+ (t nil))))
+ (store-variable (var)
+ (if (member var permanent-variables)
+ (make-permanent-register (vector-push-extend var stack-registers))
+ (make-temporary-register (vector-push-extend var local-registers))))
(parse-variable (var)
;; If we've already seen this variable just return the register it's
;; in, otherwise allocate a register for it and return that.
(or (find-variable var)
- (make-temporary-register (vector-push-extend var registers))))
+ (store-variable var)))
(parse-structure (structure reg)
(destructuring-bind (functor . arguments) structure
;; If we've been given a register to hold this structure (i.e.
;; we're parsing a top-level argument) use it. Otherwise allocate
- ;; a fresh one.
- (let ((reg (or reg (vector-push-extend nil registers))))
- (setf (aref registers reg)
+ ;; a fresh one. Note that structures always live in local
+ ;; registers, never permanent ones.
+ (let ((reg (or reg (vector-push-extend nil local-registers))))
+ (setf (aref local-registers reg)
(cons functor (mapcar #'parse arguments)))
(make-temporary-register reg))))
(parse (term &optional register)
@@ -199,20 +213,24 @@
((variable-p term) (parse-variable term))
((symbolp term) (parse (list term) register)) ; f -> f/0
((listp term) (parse-structure term register))
- (t (error "Cannot parse term ~S." term)))))
+ (t (error "Cannot parse term ~S." term))))
+ (make-assignment-list (registers register-maker)
+ (loop :for i :from 0
+ :for contents :across registers
+ :collect
+ (cons (funcall register-maker i)
+ contents))))
;; Arguments are handled specially. We parse the children as normal,
;; and then fill in the argument registers after each child.
(loop :for argument :in arguments
:for i :from 0
:for parsed = (parse argument i)
;; If the argument didn't fill itself in (structure), do it.
- :when (not (aref registers i))
- :do (setf (aref registers i) parsed))
- (values (loop :for i :from 0 ; turn the register array into an assignment list
- :for contents :across registers
- :collect
- (cons (make-temporary-register i)
- contents))
+ :when (not (aref local-registers i))
+ :do (setf (aref local-registers i) parsed))
+ (values (append
+ (make-assignment-list local-registers #'make-temporary-register)
+ (make-assignment-list stack-registers #'make-permanent-register))
predicate
arity))))
@@ -322,7 +340,7 @@
(defun tokenize-term (term permanent-variables flattener)
(multiple-value-bind (assignments functor arity)
- (parse-term term)
+ (parse-term term permanent-variables)
(values (->> assignments
(funcall flattener)
tokenize-assignments)
--- a/src/wam/constants.lisp Thu Apr 14 17:16:20 2016 +0000
+++ b/src/wam/constants.lisp Fri Apr 15 20:28:35 2016 +0000
@@ -18,6 +18,19 @@
:documentation "Maximum size of the WAM heap.")
+(define-constant +stack-word-size+ 16
+ :documentation "Size (in bits) of each word in WAM stack.")
+
+(define-constant +stack-limit+ (expt 2 +stack-word-size+)
+ ;; We can only address 2^value-bits cells, and since stack address are
+ ;; themselves stored on the stack (e.g. the environment continuation pointer)
+ ;; they can only reference so much memory.
+ ;;
+ ;; todo: we might want to limit this further to prevent the stack from growing
+ ;; too large.
+ :documentation "Maximum size of the WAM stack.")
+
+
(define-constant +code-word-size+ 16
:documentation "Size (in bits) of each word in the code store.")
@@ -60,6 +73,16 @@
"The maximum size (in bytes of bytecode) a query may compile to.")
+(define-constant +tag-local-register+ #b0
+ :documentation "A local register (X_n or A_n).")
+
+(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.")
+
+
;;;; Opcodes
;;; Program
(define-constant +opcode-get-structure+ 1)
--- a/src/wam/dump.lisp Thu Apr 14 17:16:20 2016 +0000
+++ b/src/wam/dump.lisp Fri Apr 15 20:28:35 2016 +0000
@@ -16,9 +16,9 @@
(+tag-reference+
(if (= addr (cell-value cell))
"unbound variable "
- (format nil "var pointer to ~D " (cell-value cell))))
+ (format nil "var pointer to ~4,'0X " (cell-value cell))))
(+tag-structure+
- (format nil "structure pointer to ~D " (cell-value cell)))
+ (format nil "structure pointer to ~4,'0X " (cell-value cell)))
(+tag-functor+
(destructuring-bind (functor . arity)
(wam-functor-lookup wam (cell-functor-index cell))
@@ -30,14 +30,14 @@
;; This code is awful, sorry.
(let ((heap (wam-heap wam)))
(format t "HEAP~%")
- (format t " +------+-----+--------------+--------------------------------------+~%")
- (format t " | ADDR | TYP | VALUE | DEBUG |~%")
- (format t " +------+-----+--------------+--------------------------------------+~%")
+ (format t " +------+-----+----------+--------------------------------------+~%")
+ (format t " | ADDR | TYP | VALUE | DEBUG |~%")
+ (format t " +------+-----+----------+--------------------------------------+~%")
(when (> from 0)
- (format t " | ⋮ | ⋮ | ⋮ | |~%"))
+ (format t " | ⋮ | ⋮ | ⋮ | |~%"))
(flet ((print-cell (i cell indent)
(let ((hi (= i highlight)))
- (format t "~A ~4@A | ~A | ~12@A | ~36A ~A~%"
+ (format t "~A ~4,'0X | ~A | ~8,'0X | ~36A ~A~%"
(if hi "==>" " |")
i
(cell-type-short-name cell)
@@ -55,11 +55,50 @@
(when (not (zerop indent))
(decf indent))))))
(when (< to (length heap))
- (format t " | ⋮ | ⋮ | ⋮ | |~%"))
- (format t " +------+-----+--------------+--------------------------------------+~%")
+ (format t " | ⋮ | ⋮ | ⋮ | |~%"))
+ (format t " +------+-----+----------+--------------------------------------+~%")
(values)))
+(defun dump-stack (wam &optional (e (wam-environment-pointer wam)))
+ (format t "STACK~%")
+ (format t " +------+----------+-------------------------------+~%")
+ (format t " | ADDR | VALUE | |~%")
+ (format t " +------+----------+-------------------------------+~%")
+ (loop :with n = nil
+ :with arg = 0
+ :for offset = 0 :then (1+ offset)
+ :for cell :across (wam-stack wam)
+ :for addr :from 0 :do
+ (format t " | ~4,'0X | ~8,'0X | ~30A|~A~A~%"
+ addr
+ cell
+ (cond
+ ((= offset 0) "CE ===========================")
+ ((= offset 1) "CP")
+ ((= offset 2)
+ (if (zerop cell)
+ (progn
+ (setf offset -1)
+ "N: EMPTY")
+ (progn
+ (setf n cell)
+ (format nil "N: ~D" cell))))
+ ((< arg n)
+ (prog1
+ (format nil " Y~D: ~4,'0X"
+ arg
+ ;; look up the actual cell in the heap
+ (cell-aesthetic (wam-heap-cell wam cell)))
+ (when (= n (incf arg))
+ (setf offset -1
+ n nil
+ arg 0)))))
+ (if (= addr (wam-environment-pointer wam)) " <- E" "")
+ (if (= addr e) " <- FRAME" "")))
+ (format t " +------+----------+-------------------------------+~%"))
+
+
(defun pretty-functor (functor-index functor-list)
(when functor-list
(destructuring-bind (symbol . arity)
@@ -169,15 +208,12 @@
:for reg :across (wam-registers wam)
:for contents = (when (not (= reg (1- +heap-limit+)))
(wam-register-cell wam i))
- :do (format t "~5@A ->~6@A ~A ~A~%"
+ :when contents
+ :do (format t "~5@A ->~6@A ~10A ~A~%"
(format nil "X~D" i)
reg
- (if contents
- (cell-aesthetic contents)
- "unset")
- (if contents
- (format nil "; ~A" (extract-thing wam reg))
- ""))))
+ (cell-aesthetic contents)
+ (format nil "; ~A" (extract-thing wam reg)))))
(defun dump-wam-functors (wam)
(format t " FUNCTORS: ~S~%" (wam-functors wam)))
@@ -194,14 +230,18 @@
(defun dump-wam (wam from to highlight)
(format t " FAIL: ~A~%" (wam-fail wam))
- (format t " MODE: ~A~%" (wam-mode wam))
+ (format t " MODE: ~S~%" (wam-mode wam))
(dump-wam-functors wam)
(format t "HEAP SIZE: ~A~%" (length (wam-heap wam)))
(format t "PROGRAM C: ~A~%" (wam-program-counter wam))
+ (format t "CONT PTR: ~A~%" (wam-continuation-pointer wam))
+ (format t "ENVIR PTR: ~A~%" (wam-environment-pointer wam))
(dump-wam-registers wam)
(format t "~%")
(dump-heap wam from to highlight)
(format t "~%")
+ (dump-stack wam)
+ (format t "~%")
(dump-labels wam)
(dump-code wam))
--- a/src/wam/instructions.lisp Thu Apr 14 17:16:20 2016 +0000
+++ b/src/wam/instructions.lisp Fri Apr 15 20:28:35 2016 +0000
@@ -276,7 +276,7 @@
(setf (wam-continuation-pointer wam) ; CP <- next instruction
(+ (wam-program-counter wam)
(instruction-size +opcode-call+))
- (wam-program-counter wam) ; PC <- target
+ (wam-program-counter wam) ; PC <- target
target))
(fail! wam "Tried to call unknown procedure.")))
(values))
--- a/src/wam/opcodes.lisp Thu Apr 14 17:16:20 2016 +0000
+++ /dev/null Thu Jan 01 00:00:00 1970 +0000
@@ -1,65 +0,0 @@
-(in-package #:bones.wam)
-
-;;; This file contains some basic helpers for working with opcodes themselves.
-;;; For the actual implementation of the instructions, see instructions.lisp.
-
-
-(defun* instruction-size ((opcode opcode))
- (: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+ 3)
- (+opcode-unify-variable+ 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))
- (: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-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-call+ "CALL")
- (+opcode-proceed+ "PROCEED")))
-
-(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-put-structure+ "PUTS")
- (+opcode-set-variable+ "SVAR")
- (+opcode-set-value+ "SVLU")
- (+opcode-put-variable+ "PVAR")
- (+opcode-put-value+ "PVLU")
-
- (+opcode-call+ "CALL")
- (+opcode-proceed+ "PROC")))
--- a/src/wam/types.lisp Thu Apr 14 17:16:20 2016 +0000
+++ b/src/wam/types.lisp Fri Apr 15 20:28:35 2016 +0000
@@ -13,6 +13,9 @@
(deftype heap-index ()
`(integer 0 ,(1- +heap-limit+)))
+(deftype stack-index ()
+ `(integer 0 ,(1- +stack-limit+)))
+
(deftype register-index ()
`(integer 0 ,(1- +register-count+)))
@@ -34,5 +37,32 @@
; either an address or the sentinal
`(integer 0 ,(1- +code-limit+)))
+
(deftype opcode ()
'(integer 0 12))
+
+
+(deftype register-designator ()
+ 'code-word)
+
+(deftype register-designator-tag ()
+ `(member
+ ,+tag-stack-register+
+ ,+tag-local-register+))
+
+
+(deftype stack-frame-size ()
+ `(integer 0 ,+register-count+))
+
+(deftype continuation-pointer ()
+ 'code-index)
+
+(deftype environment-pointer ()
+ 'stack-index)
+
+(deftype stack-cell ()
+ '(or
+ environment-pointer ; CE
+ continuation-pointer ; CP
+ stack-frame-size ; N
+ heap-index)) ; YN
--- a/src/wam/wam.lisp Thu Apr 14 17:16:20 2016 +0000
+++ b/src/wam/wam.lisp Fri Apr 15 20:28:35 2016 +0000
@@ -34,9 +34,21 @@
: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)
:documentation "An array of the 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-cell)
+ :documentation "The local stack for storing stack frames.")
(fail
:accessor wam-fail
:initform nil
@@ -64,6 +76,11 @@
:initform 0
:type code-index
:documentation "The Continuation Pointer into the WAM code store.")
+ (environment-pointer
+ :accessor wam-environment-pointer
+ :initform 0
+ :type stack-index
+ :documentation "The Environment Pointer into the WAM stack.")
(mode
:accessor wam-mode
:initform nil
@@ -103,9 +120,101 @@
(setf (aref (wam-heap wam) address) new-value))
+;;;; Stack
+;;; Stack frames are laid out like so:
+;;;
+;;; |PREV|
+;;; | CE | <-- environment-pointer
+;;; | CP |
+;;; | N |
+;;; | Y0 |
+;;; | .. |
+;;; | YN |
+;;; |NEXT| <-- fill-pointer
+
+(defun* wam-stack-pointer ((wam wam))
+ (:returns stack-index)
+ "Return the current stack pointer of the WAM."
+ (fill-pointer (wam-stack wam)))
+
+
+(defun* wam-stack-cell ((wam wam) (address stack-index))
+ (:returns stack-index)
+ "Return the stack cell at the given address."
+ (aref (wam-stack wam) address))
+
+(defun (setf wam-stack-cell) (new-value wam address)
+ (setf (aref (wam-stack wam) address) new-value))
+
+
+(defun* wam-stack-frame-ce ((wam wam)
+ &optional
+ ((e environment-pointer) (wam-environment-pointer wam)))
+ (:returns environment-pointer)
+ (wam-stack-cell wam e))
+
+(defun* wam-stack-frame-cp ((wam wam)
+ &optional
+ ((e environment-pointer) (wam-environment-pointer wam)))
+ (:returns continuation-pointer)
+ (wam-stack-cell wam (1+ e)))
+
+(defun* wam-stack-frame-n ((wam wam)
+ &optional
+ ((e environment-pointer) (wam-environment-pointer wam)))
+ (:returns register-index)
+ (wam-stack-cell wam (+ 2 e)))
+
+(defun* wam-stack-frame-arg ((wam wam)
+ (n register-index)
+ &optional
+ ((e environment-pointer) (wam-environment-pointer wam)))
+ (:returns heap-index)
+ (wam-stack-cell wam (+ 3 n e)))
+
+(defun* wam-stack-frame-arg-cell ((wam wam)
+ (n register-index)
+ &optional
+ ((e environment-pointer) (wam-environment-pointer wam)))
+ (:returns heap-cell)
+ (wam-heap-cell wam (wam-stack-frame-arg wam n e)))
+
+
+(defun* wam-stack-frame-size ((wam wam)
+ &optional
+ ((e environment-pointer) (wam-environment-pointer wam)))
+ (:returns (integer 3 1024)) ; TODO: Type this better
+ "Return the size of the stack frame starting at environment pointer `e`."
+ (+ (wam-stack-frame-n wam e) 3))
+
+
+(defun* wam-stack-push! ((wam wam) (cell stack-cell))
+ (:returns (values stack-cell stack-index))
+ "Push the cell onto the WAM stack and increment the stack pointer.
+
+ Returns the cell and the address it was pushed to.
+
+ "
+ (with-slots (stack) wam
+ (if (= +stack-limit+ (fill-pointer stack))
+ (error "WAM stack exhausted.")
+ (values cell (vector-push-extend cell stack)))))
+
+(defun* wam-stack-pop-environment! ((wam wam))
+ "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)
+ (decf (fill-pointer stack) frame-size))))
+
+
+;;;; Resetting
(defun* wam-truncate-heap! ((wam wam))
(setf (fill-pointer (wam-heap wam)) 0))
+(defun* wam-truncate-stack! ((wam wam))
+ (setf (fill-pointer (wam-stack wam)) 0))
+
(defun* wam-reset-registers! ((wam wam))
(loop :for i :from 0 :below +register-count+ :do
(setf (wam-register wam i)
@@ -114,6 +223,7 @@
(defun* wam-reset! ((wam wam))
(wam-truncate-heap! wam)
+ (wam-truncate-stack! wam)
(wam-reset-registers! wam)
(setf (wam-program-counter wam) 0)
(setf (wam-continuation-pointer wam) 0)
@@ -188,8 +298,8 @@
;;; A register contains the address of a cell in the heap.
(defun* wam-register ((wam wam) (register register-index))
- (:returns heap-cell)
- "Return the WAM register with the given index."
+ (:returns heap-index)
+ "Return the value of the WAM register with the given index."
(aref (wam-registers wam) register))
(defun (setf wam-register) (new-value wam register)