# HG changeset patch # User Steve Losh # Date 1460773229 0 # Node ID 2f0b5c92febe18ee4a3209311af512b9989f06d6 # Parent f0f0c180ae1dacbc7e8f39f18e0e0a3713fa8e78 Implement (mostly) register designators The compilation part is finished, only need to get them into the instructions now. Also implemented ALOC/DEAL and did a bunch of refactoring. diff -r f0f0c180ae1d -r 2f0b5c92febe .lispwords --- 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) diff -r f0f0c180ae1d -r 2f0b5c92febe package.lisp --- 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 diff -r f0f0c180ae1d -r 2f0b5c92febe src/make-quickutils.lisp --- 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") diff -r f0f0c180ae1d -r 2f0b5c92febe src/quickutils.lisp --- 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 ;;;; diff -r f0f0c180ae1d -r 2f0b5c92febe src/utils.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)) diff -r f0f0c180ae1d -r 2f0b5c92febe src/wam/bytecode.lisp --- 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)))) diff -r f0f0c180ae1d -r 2f0b5c92febe src/wam/compile.lisp --- 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) diff -r f0f0c180ae1d -r 2f0b5c92febe src/wam/constants.lisp --- 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) diff -r f0f0c180ae1d -r 2f0b5c92febe src/wam/dump.lisp --- 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) diff -r f0f0c180ae1d -r 2f0b5c92febe src/wam/instructions.lisp --- 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 diff -r f0f0c180ae1d -r 2f0b5c92febe src/wam/types.lisp --- 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 diff -r f0f0c180ae1d -r 2f0b5c92febe src/wam/wam.lisp --- 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.