--- a/Makefile Mon May 02 19:29:36 2016 +0000
+++ b/Makefile Sun May 08 21:25:08 2016 +0000
@@ -25,6 +25,4 @@
hg -R ~/src/sjl.bitbucket.org push
bench:
- # jesus christ quicklisp
- rm -rf ~/.cache/common-lisp
sbcl-rlwrap --noinform --load examples/bench.lisp --eval '(quit)'
--- a/examples/bench.lisp Mon May 02 19:29:36 2016 +0000
+++ b/examples/bench.lisp Sun May 08 21:25:08 2016 +0000
@@ -1,14 +1,37 @@
-(declaim (optimize (speed 3) (safety 1) (debug 0)))
-
(ql:quickload 'bones)
(load "examples/ggp-paip.lisp")
(load "examples/ggp.lisp")
-(in-package :bones.paip)
-(format t "PAIP ------------------------------~%")
-(time (dfs-exhaust))
+(in-package :bones)
+
+(defun reload ()
+ (let ((*standard-output* (make-broadcast-stream))
+ (*debug-io* (make-broadcast-stream))
+ (*terminal-io* (make-broadcast-stream))
+ (*error-output* (make-broadcast-stream)))
+ (asdf:load-system 'bones :force t)))
+
+(defun run-test ()
+ (reload)
+
+ (format t "PAIP ------------------------------~%")
+ (time (bones.paip::dfs-exhaust))
-(in-package :bones.wam)
-(format t "WAM -------------------------------~%")
-(time (dfs-exhaust))
+ (format t "WAM -------------------------------~%")
+ (time (bones.wam::dfs-exhaust)))
+
+(format t "~%~%====================================~%")
+(format t "(speed 3) (safety 1) (debug 1)~%")
+(declaim (optimize (speed 3) (safety 1) (debug 1)))
+(run-test)
+
+(format t "~%~%====================================~%")
+(format t "(speed 3) (safety 1) (debug 0)~%")
+(declaim (optimize (speed 3) (safety 1) (debug 0)))
+(run-test)
+
+(format t "~%~%====================================~%")
+(format t "(speed 3) (safety 0) (debug 0)~%")
+(declaim (optimize (speed 3) (safety 0) (debug 0)))
+(run-test)
--- a/examples/ggp-paip.lisp Mon May 02 19:29:36 2016 +0000
+++ b/examples/ggp-paip.lisp Sun May 08 21:25:08 2016 +0000
@@ -1,8 +1,5 @@
(in-package #:bones.paip)
-(declaim (optimize (speed 1) (safety 3) (debug 1)))
-; (declaim (optimize (speed 3) (safety 1) (debug 0)))
-
(clear-db)
(rule (member ?thing (cons ?thing ?rest)))
--- a/examples/ggp.lisp Mon May 02 19:29:36 2016 +0000
+++ b/examples/ggp.lisp Sun May 08 21:25:08 2016 +0000
@@ -1,8 +1,5 @@
(in-package #:bones.wam)
-; (declaim (optimize (speed 1) (safety 3) (debug 1)))
-(declaim (optimize (speed 3) (safety 1) (debug 0)))
-
(defparameter *d* (make-database))
(with-database *d*
--- a/package.lisp Mon May 02 19:29:36 2016 +0000
+++ b/package.lisp Sun May 08 21:25:08 2016 +0000
@@ -9,6 +9,7 @@
#:bones.quickutils)
(:export
#:repeat
+ #:hex
#:topological-sort
#:push-if-new))
--- a/src/utils.lisp Mon May 02 19:29:36 2016 +0000
+++ b/src/utils.lisp Sun May 08 21:25:08 2016 +0000
@@ -34,6 +34,9 @@
`(dotimes (,(gensym) ,n)
,@body))
+(defun hex (d)
+ (format nil "~X" d))
+
;;;; Topological Sort
;;; Adapted from the AMOP book to add some flexibility (and remove the
--- a/src/wam/cells.lisp Mon May 02 19:29:36 2016 +0000
+++ b/src/wam/cells.lisp Sun May 08 21:25:08 2016 +0000
@@ -65,12 +65,12 @@
(eswitch ((cell-type cell))
(+tag-null+ "")
(+tag-structure+
- (format nil " ~D" (cell-value cell)))
+ (format nil " ~X" (cell-value cell)))
(+tag-functor+
- (format nil " ~D"
+ (format nil " ~X"
(cell-functor-index cell)))
(+tag-reference+
- (format nil " ~D" (cell-value cell))))))
+ (format nil " ~X" (cell-value cell))))))
(defun* cell-null-p ((cell heap-cell))
--- a/src/wam/constants.lisp Mon May 02 19:29:36 2016 +0000
+++ b/src/wam/constants.lisp Sun May 08 21:25:08 2016 +0000
@@ -13,11 +13,6 @@
:documentation "Bitmask for masking the cell type tags.")
-(define-constant +heap-limit+ (expt 2 +cell-value-width+)
- ;; We can only address 2^value-bits cells.
- :documentation "Maximum size of the WAM heap.")
-
-
(define-constant +code-word-size+ 16
:documentation "Size (in bits) of each word in the code store.")
@@ -44,37 +39,53 @@
(define-constant +register-count+ 2048
:documentation "The number of registers the WAM has available.")
+
(define-constant +maximum-arity+ 1024
:documentation "The maximum allowed arity of functors.")
-
(define-constant +maximum-query-size+ 1024
:documentation
"The maximum size (in bytes of bytecode) a query may compile to.")
-(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.
+(define-constant +stack-limit+ 2048
:documentation "Maximum size of the WAM stack.")
(define-constant +stack-frame-size-limit+ (+ 7 +register-count+)
:documentation "The maximum size, in stack frame words, that a stack frame could be.")
-(define-constant +trail-limit+ (expt 2 +stack-word-size+)
+(define-constant +stack-start+ +register-count+
+ :documentation "The address in the store of the first cell of the stack.")
+
+(define-constant +stack-end+ (+ +stack-start+ +stack-limit+)
+ :documentation "The address in the store one past the last cell in the stack.")
+
+(define-constant +heap-start+ +stack-end+
+ :documentation "The address in the store of the first cell of the heap.")
+
+(define-constant +trail-limit+ (expt 2 +cell-width+)
;; The trail's fill pointer is stored inside choice frames on the stack, so it
- ;; needs to be able to fit inside a stack word.
+ ;; needs to be able to fit inside a stack word. We don't tag it, though, so
+ ;; we can technically use all of the cell bits if we want.
:documentation "The maximum number of variables that may exist in the trail.")
+(define-constant +store-limit+ (expt 2 16)
+ :documentation "Maximum size of the WAM store.")
+
+(define-constant +heap-limit+ (- +store-limit+ +register-count+ +stack-limit+)
+ ;; The heap gets whatever's left over after the registers and stack have taken
+ ;; their chunk of memory.
+ :documentation "Maximum size of the WAM heap.")
+
+
+(define-constant +functor-limit+ (expt 2 +cell-value-width+)
+ ;; Functors are referred to by their index into the functor array. This index
+ ;; is stored in the value part of functor cells.
+ :documentation "The maximum number of functors the WAM can keep track of.")
+
+
;;;; Opcodes
;;; Program
(define-constant +opcode-noop+ 0)
--- a/src/wam/dump.lisp Mon May 02 19:29:36 2016 +0000
+++ b/src/wam/dump.lisp Sun May 08 21:25:08 2016 +0000
@@ -1,10 +1,11 @@
(in-package #:bones.wam)
(defun registers-pointing-to (wam addr)
- (loop :for reg :across (wam-local-registers wam)
- :for i :from 0
- :when (= reg addr)
- :collect i))
+ (loop
+ :for r :from 0 :below +register-count+
+ :for reg = (wam-local-register wam r)
+ :when (= reg addr)
+ :collect r))
(defun heap-debug (wam addr cell indent-p)
(format
@@ -28,12 +29,12 @@
(defun dump-heap (wam from to highlight)
;; This code is awful, sorry.
- (let ((heap (wam-heap wam)))
+ (let ((store (wam-store wam)))
(format t "HEAP~%")
(format t " +------+-----+----------+--------------------------------------+~%")
(format t " | ADDR | TYP | VALUE | DEBUG |~%")
(format t " +------+-----+----------+--------------------------------------+~%")
- (when (> from 0)
+ (when (> from +heap-start+)
(format t " | ⋮ | ⋮ | ⋮ | |~%"))
(flet ((print-cell (i cell indent)
(let ((hi (= i highlight)))
@@ -46,7 +47,7 @@
(if hi "<===" "|")))))
(loop :for i :from from :below to
:with indent = 0
- :for cell = (aref heap i)
+ :for cell = (aref store i)
:do
(progn
(print-cell i cell indent)
@@ -54,7 +55,7 @@
(setf indent (wam-functor-arity wam (cell-functor-index cell)))
(when (not (zerop indent))
(decf indent))))))
- (when (< to (length heap))
+ (when (< to (wam-heap-pointer wam))
(format t " | ⋮ | ⋮ | ⋮ | |~%"))
(format t " +------+-----+----------+--------------------------------------+~%")
(values)))
@@ -65,76 +66,69 @@
(format t " +------+----------+-------------------------------+~%")
(format t " | ADDR | VALUE | |~%")
(format t " +------+----------+-------------------------------+~%")
- (with-accessors ((stack wam-stack)
- (e wam-environment-pointer)
+ (with-accessors ((e wam-environment-pointer)
(b wam-backtrack-pointer))
wam
- (when (not (= 0 e b))
- (loop :with nargs = nil
- :with limit = (max (+ e 3) (+ b 7 2)) ; todo fix this limiting
- :with arg = 0
- :with currently-in = nil
- :for addr :from 0 :below limit
- :for cell = (aref (wam-stack wam) addr)
- :for offset = 0 :then (1+ offset)
- :do
- (when (not (zerop addr))
- (switch (addr :test #'=)
- (e (setf currently-in :frame offset 0 arg 0))
- (b (setf currently-in :choice offset 0 arg 0))))
- (format t " | ~4,'0X | ~8,'0X | ~30A|~A~A~%"
- addr
- cell
- (case currently-in ; jesus christ this needs to get fixed
- (:frame
- (cond
- ((= addr 0) "")
- ((= offset 0) "CE ===========================")
- ((= offset 1) "CP")
- ((= offset 2)
- (if (zerop cell)
- (progn
- (setf currently-in nil)
- "N: EMPTY")
- (progn
- (setf nargs cell)
- (format nil "N: ~D" cell))))
- ((< arg nargs)
- (prog1
- (format nil " Y~D: ~4,'0X"
- arg
- ;; look up the actual cell in the heap
- (cell-aesthetic (wam-heap-cell wam cell)))
- (when (= nargs (incf arg))
- (setf currently-in nil))))))
- (:choice ; sweet lord make it stop
- (cond
- ((= addr 0) "")
- ((= offset 0)
- (if (zerop cell)
- (progn
- (setf currently-in nil)
- "N: EMPTY =================")
- (progn
- (setf nargs cell)
- (format nil "N: ~D =============" cell))))
- ((= offset 1) "CE saved env pointer")
- ((= offset 2) "CP saved cont pointer")
- ((= offset 3) "CB previous choice")
- ((= offset 4) "BP next clause")
- ((= offset 5) "TR saved trail pointer")
- ((= offset 6) "H saved heap pointer")
- ((< arg nargs)
- (prog1
- (format nil " Y~D: ~4,'0X"
- arg
- ;; look up the actual cell in the heap
- (cell-aesthetic (wam-heap-cell wam cell)))
- (when (= nargs (incf arg))
- (setf currently-in nil))))))
- (t ""))
- (if (= addr e) " <- E" "")
- (if (= addr b) " <- B" "")))))
+ (when (not (= +stack-start+ e b))
+ (loop
+ :with nargs = nil
+ :with arg = 0
+ :with currently-in = nil
+ :for addr :from (1+ +stack-start+) :below (wam-stack-top wam)
+ :for cell = (wam-stack-word wam addr)
+ :for offset = 0 :then (1+ offset)
+ :do
+ (when (not (zerop addr))
+ (switch (addr :test #'=)
+ (e (setf currently-in :frame offset 0 arg 0))
+ (b (setf currently-in :choice offset 0 arg 0))))
+ (format t " | ~4,'0X | ~8,'0X | ~30A|~A~A~%"
+ addr
+ cell
+ (case currently-in ; jesus christ this needs to get fixed
+ (:frame
+ (cond
+ ((= addr +stack-start+) "")
+ ((= offset 0) "CE ===========================")
+ ((= offset 1) "CP")
+ ((= offset 2)
+ (if (zerop cell)
+ (progn
+ (setf currently-in nil)
+ "N: EMPTY")
+ (progn
+ (setf nargs cell)
+ (format nil "N: ~D" cell))))
+ ((< arg nargs)
+ (prog1
+ (format nil " Y~D: ~8,'0X" arg cell)
+ (when (= nargs (incf arg))
+ (setf currently-in nil))))))
+ (:choice ; sweet lord make it stop
+ (cond
+ ((= addr +stack-start+) "")
+ ((= offset 0)
+ (if (zerop cell)
+ (progn
+ (setf currently-in nil)
+ "N: EMPTY =================")
+ (progn
+ (setf nargs cell)
+ (format nil "N: ~D =============" cell))))
+ ((= offset 1) "CE saved env pointer")
+ ((= offset 2) "CP saved cont pointer")
+ ((= offset 3) "CB previous choice")
+ ((= offset 4) "BP next clause")
+ ((= offset 5) "TR saved trail pointer")
+ ((= offset 6) "H saved heap pointer")
+ ((< arg nargs)
+ (prog1
+ (format nil " Y~D: ~8,'0X" arg cell)
+ (when (= nargs (incf arg))
+ (setf currently-in nil))))))
+ (t ""))
+ (if (= addr e) " <- E" "")
+ (if (= addr b) " <- B" "")))))
(format t " +------+----------+-------------------------------+~%"))
@@ -282,20 +276,20 @@
(defun dump-wam-registers (wam)
(format t "REGISTERS:~%")
- (format t "~5@A ->~6@A~%" "S" (wam-subterm wam))
- (loop :for i :from 0
- :for reg :across (wam-local-registers wam)
- :for contents = (when (not (= reg (1- +heap-limit+)))
+ (format t "~5@A -> ~8@A~%" "S" (wam-subterm wam))
+ (loop :for i :from 0 :to +register-count+
+ :for reg :across (wam-store wam)
+ :for contents = (when (not (zerop reg))
(wam-heap-cell wam reg))
:when contents
- :do (format t "~5@A ->~6@A ~10A ~A~%"
+ :do (format t "~5@A -> ~8,'0X ~10A ~A~%"
(format nil "X~D" i)
reg
(cell-aesthetic contents)
(format nil "; ~A" (first (extract-things wam (list reg)))))))
(defun dump-wam-functors (wam)
- (format t " FUNCTORS: ~S~%" (wam-functors wam)))
+ (format t " FUNCTORS: ~S~%" (wam-functors wam)))
(defun dump-wam-trail (wam)
(format t " TRAIL: ")
@@ -316,13 +310,15 @@
(defun dump-wam (wam from to highlight)
- (format t " FAIL: ~A~%" (wam-fail wam))
- (format t " MODE: ~S~%" (wam-mode wam))
+ (format t " FAIL: ~A~%" (wam-fail 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: ~4,'0X~%" (wam-program-counter wam))
- (format t "CONT PTR: ~4,'0X~%" (wam-continuation-pointer wam))
- (format t "ENVIR PTR: ~4,'0X~%" (wam-environment-pointer wam))
+ (format t " HEAP SIZE: ~A~%" (- (wam-heap-pointer wam) +heap-start+))
+ (format t " PROGRAM COUNTER: ~4,'0X~%" (wam-program-counter wam))
+ (format t "CONTINUATION PTR: ~4,'0X~%" (wam-continuation-pointer wam))
+ (format t " ENVIRONMENT PTR: ~4,'0X~%" (wam-environment-pointer wam))
+ (format t " BACKTRACK PTR: ~4,'0X~%" (wam-backtrack-pointer wam))
+ (format t "HEAP BCKTRCK PTR: ~4,'0X~%" (wam-heap-backtrack-pointer wam))
(dump-wam-trail wam)
(dump-wam-registers wam)
(format t "~%")
@@ -342,12 +338,12 @@
(dump-code-store wam code +maximum-query-size+ (length code))))
(defun dump-wam-full (wam)
- (dump-wam wam 0 (length (wam-heap wam)) -1))
+ (dump-wam wam +heap-start+ (wam-heap-pointer wam) -1))
(defun dump-wam-around (wam addr width)
(dump-wam wam
- (max 0 (- addr width))
- (min (length (wam-heap wam))
+ (max +heap-start+ (- addr width))
+ (min (wam-heap-pointer wam)
(+ addr width 1))
addr))
--- a/src/wam/types.lisp Mon May 02 19:29:36 2016 +0000
+++ b/src/wam/types.lisp Sun May 08 21:25:08 2016 +0000
@@ -10,11 +10,14 @@
`(unsigned-byte ,+cell-value-width+))
+(deftype store-index ()
+ `(integer 0 ,(1- +store-limit+)))
+
(deftype heap-index ()
- `(integer 0 ,(1- +heap-limit+)))
+ `(integer ,+heap-start+ ,(1- +store-limit+)))
(deftype stack-index ()
- `(integer 0 ,(1- +stack-limit+)))
+ `(integer ,+stack-start+ ,(1- +stack-end+)))
(deftype trail-index ()
`(integer 0 ,(1- +trail-limit+)))
@@ -23,7 +26,7 @@
`(integer 0 ,(1- +register-count+)))
(deftype functor-index ()
- `(integer 0 ,(1- array-total-size-limit)))
+ `(integer 0 ,(1- +functor-limit+)))
(deftype arity ()
@@ -37,7 +40,7 @@
`(unsigned-byte ,+code-word-size+))
(deftype code-index ()
- ; either an address or the sentinal
+ ;; either an address or the sentinal
`(integer 0 ,(1- +code-limit+)))
--- a/src/wam/vm.lisp Mon May 02 19:29:36 2016 +0000
+++ b/src/wam/vm.lisp Sun May 08 21:25:08 2016 +0000
@@ -70,7 +70,7 @@
"
(when *break-on-fail*
(break "FAIL: ~A" reason))
- (if (zerop (wam-backtrack-pointer wam))
+ (if (wam-backtrack-pointer-unset-p wam)
(setf (wam-fail wam) t)
(setf (wam-program-counter wam) (wam-stack-choice-bp wam)
(wam-backtracked wam) t))
@@ -306,13 +306,13 @@
;; few instructions (which will be unify-*'s, executed in write mode).
((cell-reference-p cell)
(let ((structure-address (nth-value 1 (push-new-structure! wam)))
- (functor-address (push-new-functor! wam functor)))
+ (functor-address (nth-value 1 (push-new-functor! wam functor))))
(bind! wam addr structure-address)
(setf mode :write
s (1+ functor-address))))
- ;; If the register points at a structure cell, then we look at where that
- ;; cell points (which will be the functor cell for the structure):
+ ;; If the register points at a structure cell, then we look at where
+ ;; that cell points (which will be the functor cell for the structure):
;;
;; | N | STR | M | points at the structure, not necessarily contiguous
;; | ... |
@@ -325,15 +325,15 @@
;; (M+1 in the example above).
;;
;; What about if it's a 0-arity functor? The S register will be set to
- ;; garbage. But that's okay, because we know the next thing in the stream
- ;; of instructions will be another get-structure and we'll just blow away
- ;; the S register there.
+ ;; garbage. But that's okay, because we know the next thing in the
+ ;; stream of instructions will be another get-structure and we'll just
+ ;; blow away the S register there.
((cell-structure-p cell)
(let* ((functor-addr (cell-value cell))
(functor-cell (wam-heap-cell wam functor-addr)))
(if (matching-functor-p functor-cell functor)
- (setf s (1+ functor-addr)
- mode :read)
+ (setf mode :read
+ s (1+ functor-addr))
(backtrack! wam "Functors don't match in get-struct"))))
(t (backtrack! wam (format nil "get-struct on a non-ref/struct cell ~A"
(cell-aesthetic cell))))))))
@@ -398,13 +398,12 @@
(wam-continuation-pointer wam)))
(define-instruction %allocate ((wam wam) (n stack-frame-argcount))
- (let ((stack (wam-stack wam))
- (old-e (wam-environment-pointer wam))
+ (let ((old-e (wam-environment-pointer wam))
(new-e (wam-stack-top wam)))
- (wam-stack-ensure-size! wam (+ new-e 3 n))
- (setf (aref stack new-e) old-e ; CE
- (aref stack (+ new-e 1)) (wam-continuation-pointer wam) ; CP
- (aref stack (+ new-e 2)) n ; N
+ (wam-stack-ensure-size wam (+ new-e 3 n))
+ (setf (wam-stack-word wam new-e) old-e ; CE
+ (wam-stack-word wam (+ new-e 1)) (wam-continuation-pointer wam) ; CP
+ (wam-stack-word wam (+ new-e 2)) n ; N
(wam-environment-pointer wam) new-e))) ; E <- new-e
(define-instruction %deallocate ((wam wam))
@@ -416,17 +415,16 @@
;;;; Choice Instructions
(define-instruction %try ((wam wam) (next-clause code-index))
- (let ((stack (wam-stack wam))
- (new-b (wam-stack-top wam))
+ (let ((new-b (wam-stack-top wam))
(nargs (wam-number-of-arguments wam)))
- (wam-stack-ensure-size! wam (+ new-b 7 nargs))
- (setf (aref stack new-b) nargs ; N
- (aref stack (+ new-b 1)) (wam-environment-pointer wam) ; CE
- (aref stack (+ new-b 2)) (wam-continuation-pointer wam) ; CP
- (aref stack (+ new-b 3)) (wam-backtrack-pointer wam) ; CB
- (aref stack (+ new-b 4)) next-clause ; BP
- (aref stack (+ new-b 5)) (wam-trail-pointer wam) ; TR
- (aref stack (+ new-b 6)) (wam-heap-pointer wam) ; H
+ (wam-stack-ensure-size wam (+ new-b 7 nargs))
+ (setf (wam-stack-word wam new-b) nargs ; N
+ (wam-stack-word wam (+ new-b 1)) (wam-environment-pointer wam) ; CE
+ (wam-stack-word wam (+ new-b 2)) (wam-continuation-pointer wam) ; CP
+ (wam-stack-word wam (+ new-b 3)) (wam-backtrack-pointer wam) ; CB
+ (wam-stack-word wam (+ new-b 4)) next-clause ; BP
+ (wam-stack-word wam (+ new-b 5)) (wam-trail-pointer wam) ; TR
+ (wam-stack-word wam (+ new-b 6)) (wam-heap-pointer wam) ; H
(wam-heap-backtrack-pointer wam) (wam-heap-pointer wam) ; HB
(wam-backtrack-pointer wam) new-b) ; B
(loop :for i :from 0 :below nargs :do ; A_i
@@ -443,13 +441,14 @@
(setf (wam-environment-pointer wam) (wam-stack-choice-ce wam b)
(wam-continuation-pointer wam) (wam-stack-choice-cp wam b)
;; overwrite the next clause address in the choice point
- (aref (wam-stack wam) (+ b 4)) next-clause
+ (wam-stack-word wam (+ b 4)) next-clause
(wam-trail-pointer wam) (wam-stack-choice-tr wam b)
(wam-heap-pointer wam) (wam-stack-choice-h wam b)
(wam-heap-backtrack-pointer wam) (wam-heap-pointer wam))))
(define-instruction %trust ((wam wam))
- (let ((b (wam-backtrack-pointer wam)))
+ (let* ((b (wam-backtrack-pointer wam))
+ (old-b (wam-stack-choice-cb wam b)))
;; Restore argument registers
(loop :for i :from 0 :below (wam-stack-choice-n wam b) :do
(setf (wam-local-register wam i)
@@ -459,13 +458,22 @@
(wam-continuation-pointer wam) (wam-stack-choice-cp wam b)
(wam-trail-pointer wam) (wam-stack-choice-tr wam b)
(wam-heap-pointer wam) (wam-stack-choice-h wam b)
- (wam-backtrack-pointer wam) (wam-stack-choice-cb wam b)
- ;; Note that this last one uses the NEW value of b, so the heap
- ;; backtrack pointer gets set to the heap pointer saved in the
- ;; PREVIOUS choice point.
+ (wam-backtrack-pointer wam) old-b
+
+ ;; The book is wrong here: this last one uses the NEW value of b, so
+ ;; the heap backtrack pointer gets set to the heap pointer saved in
+ ;; the PREVIOUS choice point. Thanks to the errata at
+ ;; https://github.com/a-yiorgos/wambook/blob/master/wamerratum.txt for
+ ;; pointing this out.
;;
- ;; TODO: What if we just popped off the last stack frame?
- (wam-heap-backtrack-pointer wam) (wam-stack-choice-h wam))))
+ ;; ... well, almost. The errata is also wrong here. If we're popping
+ ;; the FIRST choice point, then just using the "previous choice
+ ;; point"'s HB is going to give us garbage, so we should check for that
+ ;; edge case too. Please kill me.
+ (wam-heap-backtrack-pointer wam)
+ (if (wam-backtrack-pointer-unset-p wam old-b)
+ +heap-start+
+ (wam-stack-choice-h wam old-b)))))
;;;; Running
--- a/src/wam/wam.lisp Mon May 02 19:29:36 2016 +0000
+++ b/src/wam/wam.lisp Sun May 08 21:25:08 2016 +0000
@@ -3,12 +3,10 @@
;;;; WAM
(declaim
;; Inline all these struct accessors, otherwise things get REAL slow.
- (inline wam-heap
+ (inline wam-store
wam-code
wam-functors
wam-code-labels
- wam-local-registers
- wam-stack
wam-fail
wam-backtracked
wam-unification-stack
@@ -22,10 +20,26 @@
wam-heap-backtrack-pointer
wam-mode))
-(defstruct (wam (:type vector) :named)
- (heap
- (make-array 1024
- :fill-pointer 0
+(defstruct (wam
+ (:print-function
+ (lambda (wam stream depth)
+ (declare (ignore depth))
+ (print-unreadable-object
+ (wam stream :type t :identity t)
+ (format stream "an wam")))))
+ (store
+ ;; The main WAM store contains three separate blocks of values:
+ ;;
+ ;; [0, +register-count+) -> the local X_n registers
+ ;; [+stack-start+, +stack-end+) -> the stack
+ ;; [+heap-start+, ...) -> the heap
+ ;;
+ ;; `+register-count+` and `+stack-start+` are the same number, and
+ ;; `+stack-end+` and `+heap-start+` are the same number as well.
+ (make-array (+ +register-count+ ; TODO: make all these configurable per-WAM
+ +stack-limit+
+ 4096)
+ :fill-pointer +stack-end+
:adjustable t
:initial-element (make-cell-null)
:element-type 'heap-cell)
@@ -53,27 +67,6 @@
(code-labels
(make-hash-table)
:read-only t)
- (local-registers
- (make-array +register-count+
- ;; Initialize to the last element in the heap for debugging.
- ;; todo: don't do this
- :initial-element (1- +heap-limit+)
- :element-type 'heap-index)
- :type (simple-array heap-index)
- :read-only t)
- (stack
- (make-array 1024
- :adjustable t
- :initial-element 0
- :element-type 'stack-word)
- :type (vector stack-word)
- :read-only t)
- (fail
- nil
- :type boolean)
- (backtracked
- nil
- :type boolean)
(unification-stack
(make-array 16
:fill-pointer 0
@@ -89,37 +82,27 @@
:element-type 'heap-index)
:type (vector heap-index)
:read-only t)
- (number-of-arguments
- 0
- :type arity)
- (subterm
- nil
- :type (or null heap-index))
- (program-counter ; P
- 0
- :type code-index)
- (continuation-pointer ; CP
- 0
- :type code-index)
- (environment-pointer ; E
- 0
- :type environment-pointer)
- (backtrack-pointer ; B
- 0
- :type backtrack-pointer)
- (heap-backtrack-pointer ; HB
- 0
- :type heap-index)
- (mode
- nil
- :type (or null (member :read :write))))
-(deftype wam ()
- ; todo lol
- '(simple-vector 19))
+ ;; Unique registers
+ (number-of-arguments 0 :type arity) ; NARGS
+ (subterm nil :type (or null heap-index)) ; S
+ (program-counter 0 :type code-index) ; P
+ (stack-pointer +stack-start+ :type stack-index) ; SP
+ (continuation-pointer 0 :type code-index) ; CP
+ (environment-pointer +stack-start+ :type environment-pointer) ; E
+ (backtrack-pointer +stack-start+ :type backtrack-pointer) ; B
+ (heap-backtrack-pointer +heap-start+ :type heap-index) ; HB
+
+ ;; Other global "registers"
+ (fail nil :type boolean)
+ (backtracked nil :type boolean)
+ (mode nil :type (or null (member :read :write))))
;;;; Heap
+;;; TODO: Should we privilege heap address 0 to mean "unset" so we have a good
+;;; sentinal value for HB, S, etc?
+
(defun* wam-heap-push! ((wam wam) (cell heap-cell))
(:returns (values heap-cell heap-index))
"Push the cell onto the WAM heap and increment the heap pointer.
@@ -127,27 +110,27 @@
Returns the cell and the address it was pushed to.
"
- (let ((heap (wam-heap wam)))
- (if (= +heap-limit+ (fill-pointer heap))
+ (let ((store (wam-store wam)))
+ (if (= +store-limit+ (fill-pointer store))
(error "WAM heap exhausted.")
- (values cell (vector-push-extend cell heap)))))
+ (values cell (vector-push-extend cell store)))))
(defun* wam-heap-pointer ((wam wam))
(:returns heap-index)
"Return the current heap pointer of the WAM."
- (fill-pointer (wam-heap wam)))
+ (fill-pointer (wam-store wam)))
(defun (setf wam-heap-pointer) (new-value wam)
- (setf (fill-pointer (wam-heap wam)) new-value))
+ (setf (fill-pointer (wam-store wam)) new-value))
(defun* wam-heap-cell ((wam wam) (address heap-index))
(:returns heap-cell)
"Return the heap cell at the given address."
- (aref (wam-heap wam) address))
+ (aref (wam-store wam) address))
(defun (setf wam-heap-cell) (new-value wam address)
- (setf (aref (wam-heap wam) address) new-value))
+ (setf (aref (wam-store wam) address) new-value))
;;;; Trail
@@ -186,36 +169,55 @@
;;;; Stack
-;;; The stack is stored as a big ol' hunk of memory in a Lisp array with one
-;;; small glitch: we reserve the first word of the stack (address 0) to mean
-;;; "uninitialized", so we have a nice sentinal value for the various pointers
-;;; into the stack.
+;;; The stack is stored as a fixed-length hunk of the main WAM store array,
+;;; between the local register and the heap, with small glitch: we reserve the
+;;; first word of the stack (address `+stack-start`) to mean "uninitialized", so
+;;; we have a nice sentinal value for the various pointers into the stack.
+
+(declaim (inline wam-stack-word))
+
+(defun assert-inside-stack (wam address action)
+ (declare (ignore wam))
+ (assert (<= +stack-start+ address (1- +stack-end+)) ()
+ "Cannot ~A stack cell at address ~X (outside the stack range ~X to ~X)"
+ action address +stack-start+ +stack-end+)
+ (assert (not (= +stack-start+ address)) ()
+ "Cannot ~A stack address zero."
+ action))
+
+(defun* wam-stack-ensure-size ((wam wam) (address stack-index))
+ (:returns :void)
+ "Ensure the WAM stack is large enough to be able to write to `address`."
+ (assert-inside-stack wam address "write")
+ (values))
+
(defun* wam-stack-word ((wam wam) (address stack-index))
(:returns stack-word)
"Return the stack word at the given address."
- (assert (not (zerop address)) (address)
- "Cannot write to stack address zero.")
- (aref (wam-stack wam) address))
+ (assert-inside-stack wam address "read")
+ (aref (wam-store wam) address))
(defun (setf wam-stack-word) (new-value wam address)
- (setf (aref (wam-stack wam) address) new-value))
+ (assert-inside-stack wam address "write")
+ (setf (aref (wam-store wam) address) new-value))
-(defun* wam-stack-ensure-size! ((wam wam)
- (address stack-index))
- (:returns :void)
- "Ensure the WAM stack is large enough to be able to write to `address`.
-
- It will be adjusted (but not beyond the limit) if necessary.
- "
- (let ((stack (wam-stack wam)))
- (if (>= address +stack-limit+)
- (error "WAM stack exhausted.")
- (while (>= address (array-total-size stack))
- ;; i uh, let's just hope this never executes more than once...
- (adjust-array stack (* 2 (array-total-size stack))))))
- (values))
+(defun* wam-backtrack-pointer-unset-p
+ ((wam wam)
+ &optional
+ ((backtrack-pointer backtrack-pointer)
+ (wam-backtrack-pointer wam)))
+ (:returns boolean)
+ (= backtrack-pointer +stack-start+))
+
+(defun* wam-environment-pointer-unset-p
+ ((wam wam)
+ &optional
+ ((environment-pointer environment-pointer)
+ (wam-environment-pointer wam)))
+ (:returns boolean)
+ (= environment-pointer +stack-start+))
;;; Stack frames are laid out like so:
@@ -257,7 +259,8 @@
((wam wam)
(n register-index)
&optional
- ((e environment-pointer) (wam-environment-pointer wam)))
+ ((e environment-pointer)
+ (wam-environment-pointer wam)))
(:returns heap-index)
(wam-stack-word wam (+ 3 n e)))
@@ -405,7 +408,9 @@
(let ((e (wam-environment-pointer wam))
(b (wam-backtrack-pointer wam)))
(cond
- ((= 0 b e) 1) ; first allocation
+ ((and (wam-backtrack-pointer-unset-p wam b)
+ (wam-environment-pointer-unset-p wam e)) ; first allocation
+ (1+ +stack-start+))
((> e b) ; the last thing on the stack is a frame
(+ e (wam-stack-frame-size wam e)))
(t ; the last thing on the stack is a choice point
@@ -414,7 +419,7 @@
;;;; Resetting
(defun* wam-truncate-heap! ((wam wam))
- (setf (fill-pointer (wam-heap wam)) 0))
+ (setf (fill-pointer (wam-store wam)) +heap-start+))
(defun* wam-truncate-trail! ((wam wam))
(setf (fill-pointer (wam-trail wam)) 0))
@@ -424,8 +429,7 @@
(defun* wam-reset-local-registers! ((wam wam))
(loop :for i :from 0 :below +register-count+ :do
- (setf (wam-local-register wam i)
- (1- +heap-limit+)))
+ (setf (wam-local-register wam i) (make-cell-null)))
(setf (wam-subterm wam) nil))
(defun* wam-reset! ((wam wam))
@@ -435,9 +439,9 @@
(wam-reset-local-registers! wam)
(setf (wam-program-counter wam) 0
(wam-continuation-pointer wam) 0
- (wam-environment-pointer wam) 0
- (wam-backtrack-pointer wam) 0
- (wam-heap-backtrack-pointer wam) 0
+ (wam-environment-pointer wam) +stack-start+
+ (wam-backtrack-pointer wam) +stack-start+
+ (wam-heap-backtrack-pointer wam) +heap-start+
(wam-backtracked wam) nil
(wam-fail wam) nil
(wam-subterm wam) nil
@@ -526,8 +530,8 @@
;;; 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.
+;;; Local/temporary/arguments registers live at the beginning of the WAM memory
+;;; store.
;;;
;;; Stack/permanent registers live on the stack, and need some extra math to
;;; find their location.
@@ -539,16 +543,16 @@
;;; instead of runtime, and register references happen A LOT at runtime.
(defun* wam-local-register ((wam wam) (register register-index))
- (:returns heap-index)
+ (:returns (or (eql 0) heap-index))
"Return the value of the WAM local register with the given index."
- (aref (wam-local-registers wam) register))
+ (aref (wam-store wam) register))
(defun (setf wam-local-register) (new-value wam register)
- (setf (aref (wam-local-registers wam) register) new-value))
+ (setf (aref (wam-store wam) register) new-value))
(defun* wam-stack-register ((wam wam) (register register-index))
- (:returns heap-index)
+ (:returns (or (eql 0) heap-index))
"Return the value of the WAM stack register with the given index."
(wam-stack-frame-arg wam register))