--- a/.lispwords Fri Apr 15 22:42:03 2016 +0000
+++ b/.lispwords Sat Apr 16 02:20:29 2016 +0000
@@ -1,2 +1,2 @@
-(1 vector-push-extend-all)
(2 code-push-instruction!)
+(1 repeat)
--- a/package.lisp Fri Apr 15 22:42:03 2016 +0000
+++ b/package.lisp Sat Apr 16 02:20:29 2016 +0000
@@ -7,6 +7,7 @@
#:defstar
#:bones.quickutils)
(:export
+ #:repeat
#:push-if-new))
(defpackage #:bones.wam
--- a/src/make-quickutils.lisp Fri Apr 15 22:42:03 2016 +0000
+++ b/src/make-quickutils.lisp Sat Apr 16 02:20:29 2016 +0000
@@ -13,6 +13,7 @@
:tree-collect
:with-gensyms
:zip
+ :alist-to-hash-table
:map-tree
)
:package "BONES.QUICKUTILS")
--- a/src/quickutils.lisp Fri Apr 15 22:42:03 2016 +0000
+++ b/src/quickutils.lisp Sat Apr 16 02:20:29 2016 +0000
@@ -2,7 +2,7 @@
;;;; See http://quickutil.org for details.
;;;; To regenerate:
-;;;; (qtlc:save-utils-as "quickutils.lisp" :utilities '(:DEFINE-CONSTANT :SET-EQUAL :CURRY :SWITCH :ENSURE-BOOLEAN :WHILE :UNTIL :TREE-MEMBER-P :TREE-COLLECT :WITH-GENSYMS :ZIP :MAP-TREE) :ensure-package T :package "BONES.QUICKUTILS")
+;;;; (qtlc:save-utils-as "quickutils.lisp" :utilities '(:DEFINE-CONSTANT :SET-EQUAL :CURRY :SWITCH :ENSURE-BOOLEAN :WHILE :UNTIL :TREE-MEMBER-P :TREE-COLLECT :WITH-GENSYMS :ZIP :ALIST-TO-HASH-TABLE :MAP-TREE) :ensure-package T :package "BONES.QUICKUTILS")
(eval-when (:compile-toplevel :load-toplevel :execute)
(unless (find-package "BONES.QUICKUTILS")
@@ -19,7 +19,8 @@
:WITH-GENSYMS :EXTRACT-FUNCTION-NAME
:SWITCH :ENSURE-BOOLEAN :UNTIL :WHILE
:TREE-MEMBER-P :TREE-COLLECT
- :TRANSPOSE :ZIP :MAP-TREE))))
+ :TRANSPOSE :ZIP :ALIST-TO-HASH-TABLE
+ :MAP-TREE))))
(defun %reevaluate-constant (name value test)
(if (not (boundp name))
@@ -266,6 +267,15 @@
(transpose lists))
+ (defun alist-to-hash-table (kv-pairs)
+ "Create a hash table populated with `kv-pairs`."
+ (let ((hashtab (make-hash-table :test #'equal)))
+ (loop
+ :for (i j) :in kv-pairs
+ :do (setf (gethash i hashtab) j)
+ :finally (return hashtab))))
+
+
(defun map-tree (function tree)
"Map `function` to each of the leave of `tree`."
(check-type tree cons)
@@ -281,6 +291,6 @@
(eval-when (:compile-toplevel :load-toplevel :execute)
(export '(define-constant set-equal curry switch eswitch cswitch
ensure-boolean while until tree-member-p tree-collect with-gensyms
- with-unique-names zip map-tree)))
+ with-unique-names zip alist-to-hash-table map-tree)))
;;;; END OF quickutils.lisp ;;;;
--- a/src/utils.lisp Fri Apr 15 22:42:03 2016 +0000
+++ b/src/utils.lisp Sat Apr 16 02:20:29 2016 +0000
@@ -17,3 +17,19 @@
(,current ,access-expr)
(,result (pushnew ,thing ,place :key ,key :test ,test)))
(not (eql ,current ,result))))))
+
+(defun invert-hash-table (ht)
+ "Jesus christ don't actually use this for anything but debugging.
+
+ Inverts the keys/values of a hash table.
+
+ "
+ (alist-to-hash-table
+ (loop :for k :being :the :hash-keys :of ht
+ :using (hash-value v)
+ :collect (list v k))))
+
+(defmacro repeat (n &body body)
+ "Repeat `body` `n` times."
+ `(dotimes (,(gensym) ,n)
+ ,@body))
--- a/src/wam/bytecode.lisp Fri Apr 15 22:42:03 2016 +0000
+++ b/src/wam/bytecode.lisp Sat Apr 16 02:20:29 2016 +0000
@@ -22,7 +22,9 @@
(+opcode-put-value+ 3)
(+opcode-call+ 2)
- (+opcode-proceed+ 1)))
+ (+opcode-proceed+ 1)
+ (+opcode-allocate+ 2)
+ (+opcode-deallocate+ 1)))
(defun* opcode-name ((opcode opcode))
@@ -41,7 +43,9 @@
(+opcode-put-value+ "PUT-VALUE")
(+opcode-call+ "CALL")
- (+opcode-proceed+ "PROCEED")))
+ (+opcode-proceed+ "PROCEED")
+ (+opcode-allocate+ "ALLOCATE")
+ (+opcode-deallocate+ "DEALLOCATE")))
(defun* opcode-short-name ((opcode opcode))
(:returns string)
@@ -59,7 +63,9 @@
(+opcode-put-value+ "PVLU")
(+opcode-call+ "CALL")
- (+opcode-proceed+ "PROC")))
+ (+opcode-proceed+ "PROC")
+ (+opcode-allocate+ "ALOC")
+ (+opcode-deallocate+ "DEAL")))
;;;; Register Designators
@@ -108,3 +114,12 @@
(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/compile.lisp Fri Apr 15 22:42:03 2016 +0000
+++ b/src/wam/compile.lisp Sat Apr 16 02:20:29 2016 +0000
@@ -24,6 +24,23 @@
(:returns register)
(make-instance 'register :type type :number number))
+(defun* make-temporary-register ((number register-number) (arity arity))
+ (:returns register)
+ (make-register (if (< number arity) :argument :local)
+ number))
+
+(defun* make-permanent-register ((number register-number) (arity arity))
+ (:returns register)
+ (declare (ignore arity))
+ (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"
@@ -31,7 +48,8 @@
(:argument #\A)
(:local #\X)
(:permanent #\Y))
- (register-number register)))
+ (+ (register-number register)
+ (if *off-by-one* 1 0))))
(defmethod print-object ((object register) stream)
(print-unreadable-object (object stream :identity nil :type nil)
@@ -51,8 +69,8 @@
(ensure-boolean
(and (or (eql (register-type r1)
(register-type r2))
- ;; local and argument registers are actually the same register, just
- ;; named differently
+ ;; 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))))
(= (register-number r1)
@@ -166,33 +184,32 @@
(let* ((predicate (first term))
(arguments (rest term))
(arity (length arguments))
- ;; Preallocate enough registers for all of the arguments.
- ;; We'll fill them in later.
+ ;; 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))
- (stack-registers (make-array 64
- :fill-pointer 0
- :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.
+ ;;
+ ;; 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)))
(labels
- ((make-temporary-register (number)
- (make-register (if (< number arity) :argument :local)
- number))
- (make-permanent-register (number)
- (make-register :permanent number))
- (find-variable (var)
+ ((find-variable (var)
(let ((r (position var local-registers))
(s (position var stack-registers)))
(cond
- (r (make-temporary-register r))
- (s (make-permanent-register s))
+ (r (make-temporary-register r arity))
+ (s (make-permanent-register s arity))
(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))))
+ (make-temporary-register
+ (vector-push-extend var local-registers)
+ arity))
(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.
@@ -207,7 +224,7 @@
(let ((reg (or reg (vector-push-extend nil local-registers))))
(setf (aref local-registers reg)
(cons functor (mapcar #'parse arguments)))
- (make-temporary-register reg))))
+ (make-temporary-register reg arity))))
(parse (term &optional register)
(cond
((variable-p term) (parse-variable term))
@@ -218,7 +235,7 @@
(loop :for i :from 0
:for contents :across registers
:collect
- (cons (funcall register-maker i)
+ (cons (funcall register-maker i arity)
contents))))
;; Arguments are handled specially. We parse the children as normal,
;; and then fill in the argument registers after each child.
@@ -293,7 +310,8 @@
(-<> assignments
(topological-sort <> (find-dependencies assignments)
:key #'car
- :key-test #'register=)
+ :key-test #'register=
+ :test #'eql)
(remove-if #'variable-assignment-p <>)))
(defun flatten-query (assignments)
@@ -349,12 +367,7 @@
(defun tokenize-program-term (term permanent-variables)
"Tokenize `term` as a program term, returning its tokens, functor, and arity."
- (multiple-value-bind (tokens functor arity)
- (tokenize-term term permanent-variables #'flatten-program)
- ;; We need to shove a PROCEED token onto the end.
- (values (append tokens `((:proceed)))
- functor
- arity)))
+ (tokenize-term term permanent-variables #'flatten-program))
(defun tokenize-query-term (term permanent-variables)
"Tokenize `term` as a query term, returning its stream of tokens."
@@ -408,8 +421,8 @@
(ecase mode
(:program +opcode-get-value+)
(:query +opcode-put-value+)))
- (register-number source-register)
- (register-number argument-register)))
+ (register-to-designator source-register)
+ (register-to-designator argument-register)))
(handle-structure (destination-register functor arity)
;; OP functor reg
(push destination-register seen)
@@ -418,16 +431,12 @@
(:program +opcode-get-structure+)
(:query +opcode-put-structure+))
(wam-ensure-functor-index wam (cons functor arity))
- (register-number destination-register)))
+ (register-to-designator destination-register)))
(handle-call (functor arity)
;; CALL functor
(code-push-instruction! store
+opcode-call+
(wam-ensure-functor-index wam (cons functor arity))))
- (handle-proceed ()
- ;; PROC
- (code-push-instruction! store
- +opcode-proceed+))
(handle-register (register)
;; OP reg
(code-push-instruction! store
@@ -438,7 +447,7 @@
(ecase mode
(:program +opcode-unify-value+)
(:query +opcode-set-value+)))
- (register-number register)))
+ (register-to-designator register)))
(handle-stream (tokens)
(loop :for token :in tokens :collect
(ematch token
@@ -453,8 +462,6 @@
(handle-structure destination-register functor arity))
(`(:call ,functor ,arity)
(handle-call functor arity))
- (`(:proceed)
- (handle-proceed))
((guard register
(typep register 'register))
(handle-register register))))))
@@ -520,7 +527,19 @@
(body-tokens
(loop :for term :in body :append
(tokenize-query-term term permanent-variables))))
- (compile-tokens wam head-tokens body-tokens store))
+ (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.
+ (cond
+ ((and head body) ; a full-ass rule
+ (code-push-instruction! store +opcode-allocate+ (length permanent-variables))
+ (compile%)
+ (code-push-instruction! store +opcode-deallocate+))
+ ((and head (null body)) ; a bare fact
+ (compile%)
+ (code-push-instruction! store +opcode-proceed+))
+ (t ; just a query
+ (compile%)))))
(values))
(defun compile-query (wam query)
--- a/src/wam/constants.lisp Fri Apr 15 22:42:03 2016 +0000
+++ b/src/wam/constants.lisp Sat Apr 16 02:20:29 2016 +0000
@@ -18,19 +18,6 @@
: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.")
@@ -83,6 +70,22 @@
: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.")
+
+(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 (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 +stack-frame-size-limit+ (+ 3 +register-count+)
+ :documentation "The maximum size, in stack frame words, that a stack frame could be.")
+
+
;;;; Opcodes
;;; Program
(define-constant +opcode-get-structure+ 1)
@@ -99,6 +102,13 @@
(define-constant +opcode-put-variable+ 9)
(define-constant +opcode-put-value+ 10)
+
;;; Control
(define-constant +opcode-call+ 11)
(define-constant +opcode-proceed+ 12)
+(define-constant +opcode-allocate+ 13)
+(define-constant +opcode-deallocate+ 14)
+
+
+;;;; Debug Config
+(defparameter *off-by-one* nil)
--- a/src/wam/dump.lisp Fri Apr 15 22:42:03 2016 +0000
+++ b/src/wam/dump.lisp Sat Apr 16 02:20:29 2016 +0000
@@ -1,7 +1,7 @@
(in-package #:bones.wam)
(defun registers-pointing-to (wam addr)
- (loop :for reg :across (wam-registers wam)
+ (loop :for reg :across (wam-local-registers wam)
:for i :from 0
:when (= reg addr)
:collect i))
@@ -118,45 +118,51 @@
(defmethod instruction-details ((opcode (eql +opcode-set-variable+)) arguments functor-list)
- (format nil "SVAR~A ; X~D <- new unbound REF"
+ (format nil "SVAR~A ; ~A <- new unbound REF"
(pretty-arguments arguments)
- (first arguments)))
+ (register-designator-to-string (first arguments))))
(defmethod instruction-details ((opcode (eql +opcode-set-value+)) arguments functor-list)
- (format nil "SVLU~A ; new REF to X~D"
+ (format nil "SVLU~A ; new REF to ~A"
(pretty-arguments arguments)
- (first arguments)))
+ (register-designator-to-string (first arguments))))
(defmethod instruction-details ((opcode (eql +opcode-get-structure+)) arguments functor-list)
- (format nil "GETS~A ; X~D <- ~A"
+ (format nil "GETS~A ; ~A = ~A"
(pretty-arguments arguments)
- (second arguments)
+ (register-designator-to-string (second arguments))
(pretty-functor (first arguments) functor-list)))
(defmethod instruction-details ((opcode (eql +opcode-put-structure+)) arguments functor-list)
- (format nil "PUTS~A ; X~D <- new ~A"
+ (format nil "PUTS~A ; ~A <- new ~A"
(pretty-arguments arguments)
- (second arguments)
+ (register-designator-to-string (second arguments))
(pretty-functor (first arguments) functor-list)))
(defmethod instruction-details ((opcode (eql +opcode-get-variable+)) arguments functor-list)
- (format nil "GVAR~A ; A~D -> X~D"
+ (format nil "GVAR~A ; ~A <- ~A"
(pretty-arguments arguments)
- (second arguments)
- (first arguments)))
+ (register-designator-to-string (first arguments))
+ (register-designator-to-string (second arguments))))
(defmethod instruction-details ((opcode (eql +opcode-get-value+)) arguments functor-list)
- (format nil "GVLU~A ; A~D = X~D"
+ (format nil "GVLU~A ; ~A = ~A"
(pretty-arguments arguments)
- (second arguments)
- (first arguments)))
+ (register-designator-to-string (second arguments))
+ (register-designator-to-string (first arguments))))
(defmethod instruction-details ((opcode (eql +opcode-put-variable+)) arguments functor-list)
- (format nil "PVAR~A ; A~D <- X~D <- new unbound REF"
+ (format nil "PVAR~A ; ~A <- ~A <- new unbound REF"
(pretty-arguments arguments)
- (second arguments)
- (first arguments)))
+ (register-designator-to-string (second arguments))
+ (register-designator-to-string (first arguments))))
+
+(defmethod instruction-details ((opcode (eql +opcode-put-value+)) arguments functor-list)
+ (format nil "PVLU~A ; ~A <- ~A"
+ (pretty-arguments arguments)
+ (register-designator-to-string (second arguments))
+ (register-designator-to-string (first arguments))))
(defmethod instruction-details ((opcode (eql +opcode-call+)) arguments functor-list)
@@ -165,11 +171,17 @@
(pretty-functor (first arguments) functor-list)))
-(defun dump-code-store (wam code-store &optional
- (from 0)
- (to (length code-store)))
- (let ((addr from))
+(defun dump-code-store (wam code-store
+ &optional
+ (from 0)
+ (to (length code-store)))
+ (let ((addr from)
+ (lbls (bones.utils::invert-hash-table (wam-code-labels wam)))) ; oh god
(while (< addr to)
+ (let ((lbl (gethash addr lbls))) ; forgive me
+ (when lbl
+ (format t ";;;; BEGIN ~A~%"
+ (pretty-functor lbl (wam-functors wam)))))
(format t "; ~4,'0X: " addr)
(let ((instruction (retrieve-instruction code-store addr)))
(format t "~A~%" (instruction-details (aref instruction 0)
@@ -206,9 +218,9 @@
(format t "REGISTERS:~%")
(format t "~5@A ->~6@A~%" "S" (wam-s wam))
(loop :for i :from 0
- :for reg :across (wam-registers wam)
+ :for reg :across (wam-local-registers wam)
:for contents = (when (not (= reg (1- +heap-limit+)))
- (wam-register-cell wam i))
+ (wam-heap-cell wam reg))
:when contents
:do (format t "~5@A ->~6@A ~10A ~A~%"
(format nil "X~D" i)
--- a/src/wam/instructions.lisp Fri Apr 15 22:42:03 2016 +0000
+++ b/src/wam/instructions.lisp Sat Apr 16 02:20:29 2016 +0000
@@ -277,6 +277,8 @@
(wam-register wam argument))
(values))
+
+;;;; Control Instructions
(defun* %call ((wam wam) (functor functor-index))
(:returns :void)
(let ((target (wam-code-label wam functor)))
@@ -296,6 +298,23 @@
(wam-continuation-pointer wam))
(values))
+(defun* %allocate ((wam wam) (n stack-frame-argcount))
+ (:returns :void)
+ (setf (wam-environment-pointer wam) ; E <- new E
+ (->> wam
+ wam-environment-pointer
+ (wam-stack-push! wam) ; CE
+ (nth-value 1)))
+ (wam-stack-push! wam (wam-continuation-pointer wam)) ; CP
+ (wam-stack-push! wam n) ; N
+ (wam-stack-extend! wam n)) ; Y_n (TODO: this sucks)
+
+(defun* %deallocate ((wam wam))
+ (:returns :void)
+ (setf (wam-program-counter wam)
+ (wam-stack-frame-cp wam))
+ (wam-stack-pop-environment! wam))
+
;;;; Running
(defmacro instruction-call (wam instruction code-store pc number-of-arguments)
@@ -312,6 +331,7 @@
(defun extract-query-results (wam goal)
+ ;; TODO: rehaul this
(let ((results (list)))
(labels ((recur (original result)
(cond
--- a/src/wam/types.lisp Fri Apr 15 22:42:03 2016 +0000
+++ b/src/wam/types.lisp Sat Apr 16 02:20:29 2016 +0000
@@ -39,7 +39,7 @@
(deftype opcode ()
- '(integer 0 12))
+ '(integer 0 14))
(deftype register-designator ()
@@ -52,6 +52,9 @@
(deftype stack-frame-size ()
+ `(integer 3 ,+stack-frame-size-limit+))
+
+(deftype stack-frame-argcount ()
`(integer 0 ,+register-count+))
(deftype continuation-pointer ()
@@ -60,9 +63,9 @@
(deftype environment-pointer ()
'stack-index)
-(deftype stack-cell ()
+(deftype stack-word ()
'(or
environment-pointer ; CE
continuation-pointer ; CP
- stack-frame-size ; N
+ stack-frame-argcount ; N
heap-index)) ; YN
--- a/src/wam/wam.lisp Fri Apr 15 22:42:03 2016 +0000
+++ b/src/wam/wam.lisp Sat Apr 16 02:20:29 2016 +0000
@@ -30,14 +30,14 @@
:accessor wam-code-labels
:documentation "The mapping of functor indices -> code store addresses.")
(registers
- :reader wam-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)
- :documentation "An array of the X_i registers.")
+ :documentation "An array of the local X_i registers.")
(stack
:reader wam-stack
:initform (make-array 1024
@@ -47,7 +47,7 @@
;; debugging purposes.
;; todo: don't do this
:initial-element (1- +heap-limit+)
- :element-type 'stack-cell)
+ :element-type 'stack-word)
:documentation "The local stack for storing stack frames.")
(fail
:accessor wam-fail
@@ -138,74 +138,105 @@
(fill-pointer (wam-stack wam)))
-(defun* wam-stack-cell ((wam wam) (address stack-index))
+(defun* wam-stack-word ((wam wam) (address stack-index))
(:returns stack-index)
- "Return the stack cell at the given address."
+ "Return the stack word at the given address."
(aref (wam-stack wam) address))
-(defun (setf wam-stack-cell) (new-value wam address)
+(defun (setf wam-stack-word) (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)))
+(defun* wam-stack-frame-ce
+ ((wam wam)
+ &optional
+ ((e environment-pointer)
+ (wam-environment-pointer wam)))
(:returns environment-pointer)
- (wam-stack-cell wam e))
+ (wam-stack-word wam e))
-(defun* wam-stack-frame-cp ((wam wam)
- &optional
- ((e environment-pointer) (wam-environment-pointer wam)))
+(defun* wam-stack-frame-cp
+ ((wam wam)
+ &optional
+ ((e environment-pointer)
+ (wam-environment-pointer wam)))
(:returns continuation-pointer)
- (wam-stack-cell wam (1+ e)))
+ (wam-stack-word 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-n
+ ((wam wam)
+ &optional
+ ((e environment-pointer)
+ (wam-environment-pointer wam)))
+ (:returns stack-frame-argcount)
+ (wam-stack-word wam (+ 2 e)))
-(defun* wam-stack-frame-arg ((wam wam)
- (n register-index)
- &optional
- ((e environment-pointer) (wam-environment-pointer wam)))
+(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)))
+ (wam-stack-word wam (+ 3 n e)))
+
+(defun (setf wam-stack-frame-arg)
+ (new-value wam n &optional (e (wam-environment-pointer wam)))
+ (setf (wam-stack-word wam (+ e 3 n))
+ new-value))
-(defun* wam-stack-frame-arg-cell ((wam wam)
- (n register-index)
- &optional
- ((e environment-pointer) (wam-environment-pointer wam)))
+(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
+(defun* wam-stack-frame-size
+ ((wam wam)
+ &optional
+ ((e environment-pointer)
+ (wam-environment-pointer wam)))
+ (:returns stack-frame-size)
"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.
+(defun* wam-stack-push! ((wam wam) (word stack-word))
+ (:returns (values stack-word stack-index))
+ "Push the word onto the WAM stack and increment the stack pointer.
- Returns the cell and the address it was pushed to.
+ Returns the word 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)))))
+ (values word (vector-push-extend word stack)))))
+
+(defun* wam-stack-extend! ((wam wam) (words integer))
+ (:returns :void)
+ "Extend the WAM stack by the given number of words.
+
+ Each word is initialized to 0.
+
+ "
+ ;; TODO: this sucks, fix it
+ (with-slots (stack) wam
+ (repeat words
+ (if (= +stack-limit+ (fill-pointer stack))
+ (error "WAM stack exhausted.")
+ (vector-push-extend 0 stack))))
+ (values))
(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))))
+ (decf environment-pointer frame-size) ; lol
+ (decf (fill-pointer stack) frame-size)))) ; its fine
;;;; Resetting
@@ -215,18 +246,19 @@
(defun* wam-truncate-stack! ((wam wam))
(setf (fill-pointer (wam-stack wam)) 0))
-(defun* wam-reset-registers! ((wam wam))
+(defun* wam-reset-local-registers! ((wam wam))
(loop :for i :from 0 :below +register-count+ :do
- (setf (wam-register wam i)
+ (setf (wam-local-register wam i)
(1- +heap-limit+)))
(setf (wam-s wam) nil))
(defun* wam-reset! ((wam wam))
(wam-truncate-heap! wam)
(wam-truncate-stack! wam)
- (wam-reset-registers! wam)
+ (wam-reset-local-registers! wam)
(setf (wam-program-counter wam) 0
(wam-continuation-pointer wam) 0
+ (wam-environment-pointer wam) 0
(wam-fail wam) nil
(wam-mode wam) nil))
@@ -295,23 +327,64 @@
;;;; Registers
-;;; WAM registers are implemented as an array of a fixed number of registers.
-;;; A register contains the address of a cell in the heap.
+;;; 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).
+;;;
+;;; Local/temporary/arguments registers live in a small, fixed, preallocated
+;;; array called `registers` in the WAM object.
+;;;
+;;; Stack/permanent registers live on the stack, and need some extra math to
+;;; find their location.
+;;;
+;;; 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.
-(defun* wam-register ((wam wam) (register register-index))
+(defun* wam-local-register ((wam wam) (register register-index))
(:returns heap-index)
- "Return the value of the WAM register with the given index."
- (aref (wam-registers wam) register))
+ "Return the value of the WAM local register with the given index."
+ (aref (wam-local-registers wam) register))
+
+(defun (setf wam-local-register) (new-value wam register)
+ (setf (aref (wam-local-registers wam) register) new-value))
+
-(defun (setf wam-register) (new-value wam register)
- (setf (aref (wam-registers wam) register) new-value))
+(defun* wam-stack-register ((wam wam) (register register-index))
+ (:returns heap-index)
+ "Return the value of the WAM stack register with the given index."
+ (wam-stack-frame-arg wam register))
+
+(defun (setf wam-stack-register) (new-value wam register)
+ (setf (wam-stack-frame-arg wam register) new-value))
+
-(defun* wam-register-cell ((wam wam) (register register-index))
+(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 `register` is pointing at."
- (->> register
- (wam-register wam)
- (wam-heap-cell wam)))
+ "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.