--- a/.lispwords Tue Jul 12 21:56:01 2016 +0000
+++ b/.lispwords Wed Jul 13 18:33:09 2016 +0000
@@ -2,9 +2,9 @@
(1 repeat)
(2 define-instruction define-instructions)
(1 with-database)
-(3 with-cell)
(2 set-when-unbound)
(1 recursively)
(1 when-let)
(1 rule)
(0 push-logic-frame-with)
+(1 cell-typecase)
--- a/bones.asd Tue Jul 12 21:56:01 2016 +0000
+++ b/bones.asd Wed Jul 13 18:33:09 2016 +0000
@@ -28,7 +28,6 @@
:serial t
:components ((:file "constants")
(:file "types")
- (:file "cells")
(:file "bytecode")
(:file "wam")
(:file "compiler")
--- a/src/wam/bytecode.lisp Tue Jul 12 21:56:01 2016 +0000
+++ b/src/wam/bytecode.lisp Wed Jul 13 18:33:09 2016 +0000
@@ -1,54 +1,7 @@
(in-package #:bones.wam)
-(define-lookup instruction-size (opcode opcode instruction-size 0)
- "Return the size of an instruction for the given opcode.
-
- The size includes one word for the opcode itself and one for each argument.
-
- "
- (#.+opcode-noop+ 1)
-
- (#.+opcode-get-structure+ 3)
- (#.+opcode-get-variable-local+ 3)
- (#.+opcode-get-variable-stack+ 3)
- (#.+opcode-get-value-local+ 3)
- (#.+opcode-get-value-stack+ 3)
-
- (#.+opcode-put-structure+ 3)
- (#.+opcode-put-variable-local+ 3)
- (#.+opcode-put-variable-stack+ 3)
- (#.+opcode-put-value-local+ 3)
- (#.+opcode-put-value-stack+ 3)
-
- (#.+opcode-subterm-variable-local+ 2)
- (#.+opcode-subterm-variable-stack+ 2)
- (#.+opcode-subterm-value-local+ 2)
- (#.+opcode-subterm-value-stack+ 2)
- (#.+opcode-subterm-void+ 2)
-
- (#.+opcode-jump+ 2)
- (#.+opcode-call+ 2)
- (#.+opcode-dynamic-jump+ 1)
- (#.+opcode-dynamic-call+ 1)
- (#.+opcode-proceed+ 1)
- (#.+opcode-allocate+ 2)
- (#.+opcode-deallocate+ 1)
- (#.+opcode-done+ 1)
- (#.+opcode-try+ 2)
- (#.+opcode-retry+ 2)
- (#.+opcode-trust+ 1)
- (#.+opcode-cut+ 1)
-
- (#.+opcode-get-constant+ 3)
- (#.+opcode-put-constant+ 3)
- (#.+opcode-subterm-constant+ 2)
-
- (#.+opcode-get-list+ 2)
- (#.+opcode-put-list+ 2))
-
;;;; Opcodes
-
(defun* opcode-name ((opcode opcode))
(:returns string)
(eswitch (opcode)
@@ -135,3 +88,73 @@
(+opcode-get-list+ "GLST")
(+opcode-put-list+ "PLST")))
+
+;;;; Instructions
+(define-lookup instruction-size (opcode opcode instruction-size 0)
+ "Return the size of an instruction for the given opcode.
+
+ The size includes one word for the opcode itself and one for each argument.
+
+ "
+ (#.+opcode-noop+ 1)
+
+ (#.+opcode-get-structure+ 3)
+ (#.+opcode-get-variable-local+ 3)
+ (#.+opcode-get-variable-stack+ 3)
+ (#.+opcode-get-value-local+ 3)
+ (#.+opcode-get-value-stack+ 3)
+
+ (#.+opcode-put-structure+ 3)
+ (#.+opcode-put-variable-local+ 3)
+ (#.+opcode-put-variable-stack+ 3)
+ (#.+opcode-put-value-local+ 3)
+ (#.+opcode-put-value-stack+ 3)
+
+ (#.+opcode-subterm-variable-local+ 2)
+ (#.+opcode-subterm-variable-stack+ 2)
+ (#.+opcode-subterm-value-local+ 2)
+ (#.+opcode-subterm-value-stack+ 2)
+ (#.+opcode-subterm-void+ 2)
+
+ (#.+opcode-jump+ 2)
+ (#.+opcode-call+ 2)
+ (#.+opcode-dynamic-jump+ 1)
+ (#.+opcode-dynamic-call+ 1)
+ (#.+opcode-proceed+ 1)
+ (#.+opcode-allocate+ 2)
+ (#.+opcode-deallocate+ 1)
+ (#.+opcode-done+ 1)
+ (#.+opcode-try+ 2)
+ (#.+opcode-retry+ 2)
+ (#.+opcode-trust+ 1)
+ (#.+opcode-cut+ 1)
+
+ (#.+opcode-get-constant+ 3)
+ (#.+opcode-put-constant+ 3)
+ (#.+opcode-subterm-constant+ 2)
+
+ (#.+opcode-get-list+ 2)
+ (#.+opcode-put-list+ 2))
+
+
+;;;; Cells
+(define-lookup cell-type-name (type cell-type string "")
+ "Return the full name of a cell type."
+ (#.+cell-type-null+ "NULL")
+ (#.+cell-type-structure+ "STRUCTURE")
+ (#.+cell-type-reference+ "REFERENCE")
+ (#.+cell-type-functor+ "FUNCTOR")
+ (#.+cell-type-constant+ "CONSTANT")
+ (#.+cell-type-list+ "LIST")
+ (#.+cell-type-stack+ "STACK"))
+
+(define-lookup cell-type-short-name (type cell-type string "")
+ "Return the short name of a cell type."
+ (#.+cell-type-null+ "NUL")
+ (#.+cell-type-structure+ "STR")
+ (#.+cell-type-reference+ "REF")
+ (#.+cell-type-functor+ "FUN")
+ (#.+cell-type-constant+ "CON")
+ (#.+cell-type-list+ "LIS")
+ (#.+cell-type-stack+ "STK"))
+
--- a/src/wam/cells.lisp Tue Jul 12 21:56:01 2016 +0000
+++ /dev/null Thu Jan 01 00:00:00 1970 +0000
@@ -1,136 +0,0 @@
-(in-package #:bones.wam)
-
-;;; The cells of the WAM are essentially N bit bytes, with different chunks of
-;;; bits representing different things. All cells have type tag bits in the
-;;; low-order bits and their value in the higher-order bits:
-;;;
-;;; value type
-;;; vvvvvvvvvvvvvTTT
-;;;
-;;; The contents of the value depend on the type of cell.
-;;;
-;;; NULL cells always have a value of zero.
-;;;
-;;; STRUCTURE cell values are an index into the store, describing where the
-;;; structure starts.
-;;;
-;;; REFERENCE cell values are an index into the store, pointing at whatever the
-;;; value is bound to. Unbound variables contain their own store index as
-;;; a value.
-;;;
-;;; FUNCTOR cell values are an index into the WAM's functor array where the
-;;; `(symbol . arity)` cons lives.
-;;;
-;;; CONSTANT cells are the same as functor cells, except that they always refer
-;;; to functors with an arity of zero.
-;;;
-
-
-(declaim (inline cell-type
- cell-value))
-(defun* cell-type ((cell cell))
- (:returns cell-tag)
- (logand cell +cell-tag-bitmask+))
-
-(defun* cell-value ((cell cell))
- (:returns cell-value)
- (ash cell (- +cell-tag-width+)))
-
-
-(defun* cell-type-name ((cell cell))
- (:returns string)
- (eswitch ((cell-type cell) :test #'=)
- (+tag-null+ "NULL")
- (+tag-structure+ "STRUCTURE")
- (+tag-reference+ "REFERENCE")
- (+tag-functor+ "FUNCTOR")
- (+tag-constant+ "CONSTANT")
- (+tag-list+ "LIST")))
-
-(defun* cell-type-short-name ((cell cell))
- (:returns string)
- (eswitch ((cell-type cell) :test #'=)
- (+tag-null+ "NUL")
- (+tag-structure+ "STR")
- (+tag-reference+ "REF")
- (+tag-functor+ "FUN")
- (+tag-constant+ "CON")
- (+tag-list+ "LST")))
-
-
-(defun* cell-aesthetic ((cell cell))
- "Return a compact, human-friendly string representation of the cell."
- (format nil "[~A ~X]"
- (cell-type-short-name cell)
- (cell-value cell)))
-
-
-(declaim (inline cell-null-p
- cell-reference-p
- cell-functor-p
- cell-structure-p
- cell-constant-p
- cell-list-p))
-(defun* cell-null-p ((cell cell))
- (:returns boolean)
- (= (cell-type cell) +tag-null+))
-
-(defun* cell-reference-p ((cell cell))
- (:returns boolean)
- (= (cell-type cell) +tag-reference+))
-
-(defun* cell-functor-p ((cell cell))
- (:returns boolean)
- (= (cell-type cell) +tag-functor+))
-
-(defun* cell-structure-p ((cell cell))
- (:returns boolean)
- (= (cell-type cell) +tag-structure+))
-
-(defun* cell-constant-p ((cell cell))
- (:returns boolean)
- (= (cell-type cell) +tag-constant+))
-
-(defun* cell-list-p ((cell cell))
- (:returns boolean)
- (= (cell-type cell) +tag-list+))
-
-
-(declaim (inline make-cell
- make-cell-null
- make-cell-structure
- make-cell-reference
- make-cell-functor
- make-cell-constant
- make-cell-list))
-(defun* make-cell ((tag cell-tag) (value cell-value))
- (:returns cell)
- (values
- (logior (ash value +cell-tag-width+)
- tag)))
-
-(defun* make-cell-null ()
- (:returns cell)
- (make-cell +tag-null+ 0))
-
-(defun* make-cell-structure ((value cell-value))
- (:returns cell)
- (make-cell +tag-structure+ value))
-
-(defun* make-cell-reference ((value cell-value))
- (:returns cell)
- (make-cell +tag-reference+ value))
-
-(defun* make-cell-functor ((functor-index functor-index))
- (:returns cell)
- (make-cell +tag-functor+ functor-index))
-
-(defun* make-cell-constant ((functor-index functor-index))
- (:returns cell)
- (make-cell +tag-constant+ functor-index))
-
-(defun* make-cell-list ((value cell-value))
- (:returns cell)
- (make-cell +tag-list+ value))
-
-
--- a/src/wam/constants.lisp Tue Jul 12 21:56:01 2016 +0000
+++ b/src/wam/constants.lisp Wed Jul 13 18:33:09 2016 +0000
@@ -8,23 +8,10 @@
(define-constant ,count-symbol ,(length symbols))))
-(define-constant +cell-width+ 60
- :documentation "Number of bits in each cell.")
-
-(define-constant +cell-tag-width+ 3
- :documentation "Number of bits reserved for cell type tags.")
-
-(define-constant +cell-value-width+ (- +cell-width+ +cell-tag-width+)
- :documentation "Number of bits reserved for cell values.")
-
-(define-constant +cell-tag-bitmask+ #b111
- :documentation "Bitmask for masking the cell type tags.")
-
-
(define-constant +code-word-size+ 60
:documentation "Size (in bits) of each word in the code store.")
-(define-constant +code-limit+ (expt 2 +cell-width+)
+(define-constant +code-limit+ (expt 2 +code-word-size+)
:documentation "Maximum size of the WAM code store.")
(define-constant +code-sentinel+ (1- +code-limit+)
@@ -32,23 +19,14 @@
:documentation "Sentinel value used in the PC and CP.")
-(define-constant +tag-null+ #b000
- :documentation "An empty cell.")
-
-(define-constant +tag-structure+ #b001
- :documentation "A structure cell.")
-
-(define-constant +tag-reference+ #b010
- :documentation "A pointer to a cell.")
-
-(define-constant +tag-functor+ #b011
- :documentation "A functor.")
-
-(define-constant +tag-constant+ #b100
- :documentation "A constant (i.e. a 0-arity functor).")
-
-(define-constant +tag-list+ #b101
- :documentation "A Prolog list.")
+(define-constants +number-of-cell-types+
+ +cell-type-null+
+ +cell-type-structure+
+ +cell-type-reference+
+ +cell-type-functor+
+ +cell-type-constant+
+ +cell-type-list+
+ +cell-type-stack+)
(define-constant +register-count+ 2048
@@ -67,6 +45,7 @@
"The maximum number of code words an instruction (including opcode) might be.")
+;; TODO Make all this shit configurable at runtime
(define-constant +stack-limit+ 4096
:documentation "Maximum size of the WAM stack.")
@@ -84,19 +63,12 @@
(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. We don't tag it, though, so
- ;; we can technically use all of the cell bits if we want.
- ;;
+
+(define-constant +trail-limit+ array-total-size-limit
;; TODO: should probably limit this to something more reasonable
:documentation "The maximum number of variables that may exist in the trail.")
-
-(define-constant +store-limit+ (expt 2 +cell-value-width+)
- ;; Reference cells need to be able to store a heap address in their value
- ;; bits, so that limits the amount of addressable space we've got to work
- ;; with.
+(define-constant +store-limit+ array-total-size-limit
:documentation "Maximum size of the WAM store.")
(define-constant +heap-limit+ (- +store-limit+ +register-count+ +stack-limit+)
@@ -104,8 +76,7 @@
;; their chunk of memory.
:documentation "Maximum size of the WAM heap.")
-
-(define-constant +functor-limit+ (expt 2 +cell-value-width+)
+(define-constant +functor-limit+ array-total-size-limit
;; 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.")
--- a/src/wam/dump.lisp Tue Jul 12 21:56:01 2016 +0000
+++ b/src/wam/dump.lisp Wed Jul 13 18:33:09 2016 +0000
@@ -1,140 +1,143 @@
(in-package #:bones.wam)
-(defun registers-pointing-to (wam addr)
- (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)
+(defun heap-debug (wam address indent-p)
(format
- nil "~A~A~{<-X~A ~}"
+ nil "~A~A"
(if indent-p
" "
"")
- (switch ((cell-type cell))
- (+tag-reference+
- (if (= addr (cell-value cell))
- "unbound variable "
- (format nil "var pointer to ~4,'0X " (cell-value cell))))
- (+tag-structure+
- (format nil "structure pointer to ~4,'0X " (cell-value cell)))
- (+tag-functor+
- (destructuring-bind (functor . arity)
- (wam-functor-lookup wam (cell-value cell))
- (format nil "~A/~D " functor arity)))
- (+tag-constant+
- (format nil "~A/0 " (wam-functor-symbol wam (cell-value cell))))
- (t ""))
- (registers-pointing-to wam addr)))
+ (cell-typecase (wam address)
+ ((:reference r) (if (= address r)
+ "unbound variable "
+ (format nil "var pointer to ~8,'0X " r)))
+ ((:structure s) (format nil "struct pointer to ~8,'0X " s))
+ ((:functor f) (destructuring-bind (functor . arity)
+ (wam-functor-lookup wam f)
+ (format nil "~A/~D " functor arity)))
+ ((:constant c) (format nil "~A/0 " (wam-functor-symbol wam c)))
+ (t ""))))
-(defun dump-heap (wam from to highlight)
+
+(defun dump-cell-value (value)
+ ;; todo flesh this out
+ (typecase value
+ (fixnum (format nil "~16,'0X" value))
+ (t "~16{#<lisp object>~;~}")))
+
+
+(defun dump-heap (wam from to)
;; This code is awful, sorry.
- (let ((store (wam-store wam)))
- (format t "HEAP~%")
- (format t " +------+-----+------------------+--------------------------------------+~%")
- (format t " | ADDR | TYP | VALUE | DEBUG |~%")
- (format t " +------+-----+------------------+--------------------------------------+~%")
- (when (> from +heap-start+)
- (format t " | ⋮ | ⋮ | ⋮ | |~%"))
- (flet ((print-cell (i cell indent)
- (let ((hi (= i highlight)))
- (format t "~A ~4,'0X | ~A | ~16,'0X | ~36A ~A~%"
- (if hi "==>" " |")
- i
- (cell-type-short-name cell)
- (cell-value cell)
- (heap-debug wam i cell (> indent 0))
- (if hi "<===" "|")))))
- (loop :for i :from from :below to
- :with indent = 0
- :for cell = (aref store i)
- :do
- (progn
- (print-cell i cell indent)
- (if (cell-functor-p cell)
- (setf indent (wam-functor-arity wam (cell-value cell)))
- (when (not (zerop indent))
- (decf indent))))))
- (when (< to (wam-heap-pointer wam))
- (format t " | ⋮ | ⋮ | ⋮ | |~%"))
- (format t " +------+-----+------------------+--------------------------------------+~%")
- (values)))
+ (format t "HEAP~%")
+ (format t " +----------+-----+------------------+--------------------------------------+~%")
+ (format t " | ADDR | TYP | VALUE | DEBUG |~%")
+ (format t " +----------+-----+------------------+--------------------------------------+~%")
+ (when (> from (1+ +heap-start+))
+ (format t " | ⋮ | ⋮ | ⋮ | |~%"))
+ (flet ((print-cell (address indent)
+ (format t " | ~8,'0X | ~A | ~16,'0X | ~36A |~%"
+ address
+ (cell-type-short-name (wam-store-type wam address))
+ (dump-cell-value (wam-store-value wam address))
+ (heap-debug wam address (plusp indent)))))
+ (loop :with indent = 0
+ :for address :from from :below to
+ :do (progn
+ (print-cell address indent)
+ (cell-typecase (wam address)
+ ((:functor f) (setf indent (wam-functor-arity wam f)))
+ (t (when (not (zerop indent))
+ (decf indent)))))))
+ (when (< to (wam-heap-pointer wam))
+ (format t " | ⋮ | ⋮ | ⋮ | |~%"))
+ (format t " +----------+-----+------------------+--------------------------------------+~%")
+ (values))
+
+(defun dump-stack-frame (wam start-address)
+ (loop :with remaining = nil
+ :with arg-number = nil
+ :for address :from start-address
+ :for offset :from 0
+ :for type = (wam-store-type wam address)
+ :for value = (wam-store-value wam address)
+ :while (or (null remaining) (plusp remaining))
+ :do (format
+ t " | ~8,'0X | ~A | ~30A|~A~A~A~%"
+ address
+ (dump-cell-value value)
+ (cond
+ ((= address +stack-start+) "")
+ ((= offset 0) "CE ===========================")
+ ((= offset 1) "CP")
+ ((= offset 2) "CUT")
+ ((= offset 3) (progn
+ (setf remaining value
+ arg-number 0)
+ (format nil "N: ~D" value)))
+ (t (prog1
+ (format nil " Y~D: ~A ~A"
+ arg-number
+ (cell-type-short-name type)
+ (dump-cell-value value))
+ (decf remaining)
+ (incf arg-number))))
+ (if (= address (wam-environment-pointer wam)) " <- E" "")
+ (if (= address (wam-backtrack-pointer wam)) " <- B" "")
+ (if (= address (wam-cut-pointer wam)) " <- CUT" ""))
+ :finally (return address)))
+
+(defun dump-stack-choice (wam start-address)
+ (loop :with remaining = nil
+ :with arg-number = nil
+ :for address :from start-address
+ :for offset :from 0
+ :for type = (wam-store-type wam address)
+ :for value = (wam-store-value wam address)
+ :while (or (null remaining) (plusp remaining))
+ :do (format
+ t " | ~8,'0X | ~A | ~30A|~A~A~A~%"
+ address
+ (dump-cell-value value)
+ (cond
+ ((= address +stack-start+) "")
+ ((= offset 0) (progn
+ (setf remaining value
+ arg-number 0)
+ (format nil "N: ~D =============" value)))
+ ((= 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")
+ (t (prog1
+ (format nil " A~D: ~A ~A"
+ arg-number
+ (cell-type-short-name type)
+ (dump-cell-value value))
+ (decf remaining)
+ (incf arg-number))))
+ (if (= address (wam-environment-pointer wam)) " <- E" "")
+ (if (= address (wam-backtrack-pointer wam)) " <- B" "")
+ (if (= address (wam-cut-pointer wam)) " <- CUT" ""))
+ :finally (return address)))
(defun dump-stack (wam)
(format t "STACK~%")
- (format t " +------+------------------+-------------------------------+~%")
- (format t " | ADDR | VALUE | |~%")
- (format t " +------+------------------+-------------------------------+~%")
- (with-accessors ((e wam-environment-pointer)
- (b wam-backtrack-pointer))
- wam
+ (format t " +----------+------------------+-------------------------------+~%")
+ (format t " | ADDR | VALUE | |~%")
+ (format t " +----------+------------------+-------------------------------+~%")
+ (with-accessors ((e wam-environment-pointer) (b wam-backtrack-pointer)) wam
(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 | ~16,'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) "CUT")
- ((= offset 3)
- (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 ~A"
- arg cell (cell-aesthetic 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 " A~D: ~8,'0X ~A"
- arg cell (cell-aesthetic cell))
- (when (= nargs (incf arg))
- (setf currently-in nil))))))
- (t ""))
- (if (= addr e) " <- E" "")
- (if (= addr b) " <- B" "")))))
- (format t " +------+------------------+-------------------------------+~%"))
+ (loop :with address = (1+ +stack-start+)
+ :while (< address (wam-stack-top wam))
+ :do (cond
+ ((= address e) (setf address (dump-stack-frame wam address)))
+ ((= address b) (setf address (dump-stack-choice wam address)))
+ (t
+ (format t " | ~8,'0X | | |~%" address)
+ (incf address))))))
+ (format t " +----------+------------------+-------------------------------+~%"))
(defun pretty-functor (functor-index functor-list)
@@ -312,24 +315,22 @@
(format t "REGISTERS:~%")
(format t "~5@A -> ~8X~%" "S" (wam-subterm wam))
(loop :for register :from 0 :to +register-count+
- :for contents :across (wam-store wam)
- :when (not (cell-null-p contents))
- :do
- (format t "~5@A -> ~8,'0X ~10A ~A~%"
- (format nil "X~D" register)
- contents
- (cell-aesthetic contents)
- (format nil "; ~A" (first (extract-things wam (list register)))))))
+ :for type = (wam-store-type wam register)
+ :for value = (wam-store-value wam register)
+ :when (not (cell-type-p (wam register) :null))
+ :do (format t "~5@A -> ~A ~A ~A~%"
+ (format nil "X~D" register)
+ (cell-type-short-name type)
+ (dump-cell-value value)
+ (format nil "; ~A" (first (extract-things wam (list register)))))))
(defun dump-wam-functors (wam)
(format t " FUNCTORS: ~S~%" (wam-functors wam)))
(defun dump-wam-trail (wam)
(format t " TRAIL: ")
- (loop :for addr :across (wam-trail wam) :do
- (format t "~4,'0X ~A //"
- addr
- (cell-aesthetic (wam-store-cell wam addr))))
+ (loop :for address :across (wam-trail wam) :do
+ (format t "~8,'0X //" address))
(format t "~%"))
(defun dump-labels (wam)
@@ -342,7 +343,7 @@
address))))
-(defun dump-wam (wam from to highlight)
+(defun dump-wam (wam from to)
(format t " FAIL: ~A~%" (wam-fail wam))
(format t " BACKTRACKED?: ~A~%" (wam-backtracked wam))
(format t " MODE: ~S~%" (wam-mode wam))
@@ -357,7 +358,7 @@
(dump-wam-trail wam)
(dump-wam-registers wam)
(format t "~%")
- (dump-heap wam from to highlight)
+ (dump-heap wam from to)
(format t "~%")
(dump-stack wam)
(format t "~%")
@@ -373,13 +374,5 @@
(dump-code-store wam code +maximum-query-size+ (length code))))
(defun dump-wam-full (wam)
- (dump-wam wam +heap-start+ (wam-heap-pointer wam) -1))
+ (dump-wam wam (1+ +heap-start+) (wam-heap-pointer wam)))
-(defun dump-wam-around (wam addr width)
- (dump-wam wam
- (max +heap-start+ (- addr width))
- (min (wam-heap-pointer wam)
- (+ addr width 1))
- addr))
-
-
--- a/src/wam/types.lisp Tue Jul 12 21:56:01 2016 +0000
+++ b/src/wam/types.lisp Wed Jul 13 18:33:09 2016 +0000
@@ -1,17 +1,17 @@
(in-package #:bones.wam)
-(deftype cell ()
- `(unsigned-byte ,+cell-width+))
-
-(deftype cell-tag ()
- `(unsigned-byte ,+cell-tag-width+))
+(deftype cell-type ()
+ `(integer 0 ,(1- +number-of-cell-types+)))
(deftype cell-value ()
- `(unsigned-byte ,+cell-value-width+))
+ `(unsigned-byte 60)); soon...
-(deftype store ()
- '(simple-array cell (*)))
+(deftype type-store ()
+ '(simple-array cell-type (*)))
+
+(deftype value-store ()
+ '(simple-array cell-value (*)))
(deftype store-index ()
@@ -68,7 +68,7 @@
(deftype stack-choice-size ()
;; TODO: is this actually right? check on frame size limit vs choice point
;; size limit...
- `(integer 7 ,+stack-frame-size-limit+))
+ `(integer 8 ,+stack-frame-size-limit+))
(deftype stack-frame-argcount ()
'arity)
@@ -87,18 +87,16 @@
'(or
environment-pointer ; CE
continuation-pointer ; CP
- stack-frame-argcount ; N
- cell)) ; Yn
+ stack-frame-argcount)) ; N
(deftype stack-choice-word ()
'(or
environment-pointer ; CE
- backtrack-pointer ; B
+ backtrack-pointer ; B, CC
continuation-pointer ; CP, BP
stack-frame-argcount ; N
trail-index ; TR
- heap-index ; H
- cell)) ; An
+ heap-index)) ; H
(deftype stack-word ()
'(or stack-frame-word stack-choice-word))
@@ -109,12 +107,12 @@
;;; is defined as an array of cells, but certain things on the stack aren't
;;; actually cells (e.g. the stored continuation pointer).
;;;
-;;; This shouldn't be a problem (aside from being ugly) as long as our `cell`
-;;; type is big enough to hold the values of these non-cell things. So let's
-;;; just make sure that's the case...
+;;; This shouldn't be a problem (aside from being ugly) as long as they all fit
+;;; inside fixnums... so let's just make sure that's the case.
+
(defun sanity-check-stack-type (type)
- (assert (subtypep type 'cell) ()
- "Type ~A is too large to fit into a cell!"
+ (assert (subtypep type 'fixnum) ()
+ "Type ~A is too large!"
type)
(values))
@@ -124,5 +122,3 @@
(sanity-check-stack-type 'backtrack-pointer)
(sanity-check-stack-type 'trail-index)
(sanity-check-stack-type 'stack-word)
-
-
--- a/src/wam/vm.lisp Tue Jul 12 21:56:01 2016 +0000
+++ b/src/wam/vm.lisp Wed Jul 13 18:33:09 2016 +0000
@@ -5,96 +5,62 @@
;;;; Utilities
+(declaim (inline functors-match-p
+ constants-match-p))
+
+
(defun* push-unbound-reference! ((wam wam))
- (:returns (values cell heap-index))
- "Push a new unbound reference cell onto the heap."
- (wam-heap-push! wam (make-cell-reference (wam-heap-pointer wam))))
+ (:returns heap-index)
+ "Push a new unbound reference cell onto the heap, returning its address."
+ (wam-heap-push! wam +cell-type-reference+ (wam-heap-pointer wam)))
(defun* push-new-structure! ((wam wam))
- (:returns (values cell heap-index))
- "Push a new structure cell onto the heap.
+ (:returns heap-index)
+ "Push a new structure cell onto the heap, returning its address.
The structure cell's value will point at the next address, so make sure you
push something there too!
"
- (wam-heap-push! wam (make-cell-structure (1+ (wam-heap-pointer wam)))))
+ (wam-heap-push! wam +cell-type-structure+ (1+ (wam-heap-pointer wam))))
(defun* push-new-list! ((wam wam))
- (:returns (values cell heap-index))
- "Push a new list cell onto the heap.
+ (:returns heap-index)
+ "Push a new list cell onto the heap, returning its address.
The list cell's value will point at the next address, so make sure you push
something there too!
"
- (wam-heap-push! wam (make-cell-list (1+ (wam-heap-pointer wam)))))
+ (wam-heap-push! wam +cell-type-list+ (1+ (wam-heap-pointer wam))))
(defun* push-new-functor! ((wam wam) (functor functor-index))
- (:returns (values cell heap-index))
- "Push a new functor cell onto the heap."
- (wam-heap-push! wam (make-cell-functor functor)))
+ (:returns heap-index)
+ "Push a new functor cell onto the heap, returning its address."
+ (wam-heap-push! wam +cell-type-functor+ functor))
+
+(defun* push-new-constant! ((wam wam) (constant functor-index))
+ (:returns heap-index)
+ "Push a new constant cell onto the heap, returning its address."
+ (wam-heap-push! wam +cell-type-constant+ constant))
-(declaim (inline bound-reference-p
- unbound-reference-p
- matching-functor-p
- functors-match-p
- constants-match-p))
-
-(defun* bound-reference-p ((wam wam) (address store-index))
- (:returns boolean)
- "Return whether the cell at `address` is a bound reference."
- (let ((cell (wam-store-cell wam address)))
- (and (cell-reference-p cell)
- (not (= (cell-value cell) address)))))
-
-(defun* unbound-reference-p ((wam wam) (address store-index))
+(defun* functors-match-p ((f1 functor-index)
+ (f2 functor-index))
(:returns boolean)
- "Return whether the cell at `address` is an unbound reference."
- (let ((cell (wam-store-cell wam address)))
- (and (cell-reference-p cell)
- (= (cell-value cell) address))))
+ "Return whether the two functor cell values represent the same functor."
+ (= f1 f2))
-(defun* matching-functor-p ((cell cell)
- (functor functor-index))
- (:returns boolean)
- "Return whether `cell` is a functor cell containing `functor`."
- (and (cell-functor-p cell)
- (= (cell-value cell) functor)))
-
-(defun* functors-match-p ((functor-cell-1 cell)
- (functor-cell-2 cell))
- (:returns boolean)
- "Return whether the two functor cells represent the same functor."
- (= (cell-value functor-cell-1)
- (cell-value functor-cell-2)))
-
-(defun* constants-match-p ((constant-cell-1 cell)
- (constant-cell-2 cell))
+(defun* constants-match-p ((c1 functor-index)
+ (c2 functor-index))
(:returns boolean)
"Return whether the two constant cells represent the same functor."
- (= (cell-value constant-cell-1)
- (cell-value constant-cell-2)))
-
-
-(defmacro with-cell ((address-symbol cell-symbol) wam target &body body)
- "Bind variables to the (dereferenced) contents of the cell
-
- `target` should be an address in the WAM store.
-
- `address-symbol` and `cell-symbol` will be bound to the final address/cell
- after dereferencing `target.`
-
- "
- (once-only (wam target)
- `(let* ((,address-symbol (deref ,wam ,target))
- (,cell-symbol (wam-store-cell ,wam ,address-symbol)))
- ,@body)))
+ (= c1 c2))
;;;; "Ancillary" Functions
-(declaim (inline deref unbind!))
+(declaim (inline deref unbind! trail!))
+
(defun* backtrack! ((wam wam))
"Backtrack after a failure."
@@ -113,11 +79,10 @@
"Unbind the reference cell at `address`.
No error checking is done, so please don't try to unbind something that's not
- a reference cell.
+ (originally) a reference cell.
"
- (setf (wam-store-cell wam address)
- (make-cell-reference address)))
+ (wam-set-store-cell! wam address +cell-type-reference+ address))
(defun* unwind-trail! ((wam wam)
(trail-start trail-index)
@@ -131,8 +96,7 @@
(with-accessors ((tr wam-trail-pointer)
(h wam-heap-pointer)
(hb wam-heap-backtrack-pointer)
- (b wam-backtrack-pointer))
- wam
+ (b wam-backtrack-pointer)) wam
(loop
;; The book is, yet again, fucked. It just sets `i` to be the trail
;; pointer from the choice point frame. But what if we just popped off
@@ -162,9 +126,12 @@
"
;; SBCL won't inline recursive functions :(
- (while (bound-reference-p wam address)
- (setf address (cell-value (wam-store-cell wam address))))
- address)
+ (loop
+ (cell-typecase (wam address)
+ ((:reference ref) (if (= address ref)
+ (return address) ; unbound ref
+ (setf address ref))) ; bound ref
+ (t (return address))))) ; non-ref
(defun* bind! ((wam wam) (address-1 store-index) (address-2 store-index))
"Bind the unbound reference cell to the other.
@@ -188,25 +155,24 @@
;; would end up with a REF to a register address. This would be bad because
;; that register would probably get clobbered later, and the REF would now be
;; pointing to garbage.
- (let ((cell-1 (wam-store-cell wam address-1))
- (cell-2 (wam-store-cell wam address-2)))
- (cond
- ;; Bind (a1 <- a2) if:
- ;;
- ;; * A1 is a REF and A2 is something else, or...
- ;; * They're both REFs but A2 has a lower address than A1.
- ((and (cell-reference-p cell-1)
- (or (not (cell-reference-p cell-2))
- (< address-2 address-1)))
- (setf (wam-store-cell wam address-1) cell-2)
- (trail! wam address-1))
- ;; Bind (a2 <- a1) if A2 is a REF and A1 is something else.
- ((cell-reference-p cell-2)
- (setf (wam-store-cell wam address-2) cell-1)
- (trail! wam address-2))
- ;; wut
- (t
- (error "At least one cell must be an unbound reference when binding.")))))
+ (cond
+ ;; Bind (a1 <- a2) if:
+ ;;
+ ;; * A1 is a REF and A2 is something else, or...
+ ;; * They're both REFs but A2 has a lower address than A1.
+ ((and (cell-type-p (wam address-1) :reference)
+ (or (not (cell-type-p (wam address-2) :reference))
+ (< address-2 address-1)))
+ (wam-copy-store-cell! wam address-1 address-2)
+ (trail! wam address-1))
+
+ ;; Bind (a2 <- a1) if A2 is a REF and A1 is something else.
+ ((cell-type-p (wam address-2) :reference)
+ (wam-copy-store-cell! wam address-2 address-1)
+ (trail! wam address-2))
+
+ ;; wut
+ (t (error "At least one cell must be an unbound reference when binding."))))
(defun* unify! ((wam wam) (a1 store-index) (a2 store-index))
(wam-unification-stack-push! wam a1)
@@ -215,51 +181,57 @@
;; TODO: refactor this horror show.
(until (or (wam-fail wam)
(wam-unification-stack-empty-p wam))
- (let ((d1 (deref wam (wam-unification-stack-pop! wam)))
- (d2 (deref wam (wam-unification-stack-pop! wam))))
+ (let* ((d1 (deref wam (wam-unification-stack-pop! wam)))
+ (d2 (deref wam (wam-unification-stack-pop! wam)))
+ (t1 (wam-store-type wam d1))
+ (t2 (wam-store-type wam d2)))
(when (not (= d1 d2))
- (let ((cell-1 (wam-store-cell wam d1))
- (cell-2 (wam-store-cell wam d2)))
- (cond
- ;; If at least one is a reference, bind them.
- ;;
- ;; We know that any references we see here will be unbound, because
- ;; we deref'ed them above.
- ((or (cell-reference-p cell-1) (cell-reference-p cell-2))
- (bind! wam d1 d2))
+ (cond
+ ;; If at least one is a reference, bind them.
+ ;;
+ ;; We know that any references we see here will be unbound because
+ ;; we deref'ed them above.
+ ((or (cell-type= t1 :reference)
+ (cell-type= t2 :reference))
+ (bind! wam d1 d2))
- ;; Otherwise if they're both constants, make sure they match.
- ((and (cell-constant-p cell-1) (cell-constant-p cell-2))
- (when (not (constants-match-p cell-1 cell-2))
- (backtrack! wam)))
+ ;; Otherwise if they're both constants, make sure they match.
+ ((and (cell-type= t1 :constant)
+ (cell-type= t2 :constant))
+ (let ((c1 (wam-store-value wam d1))
+ (c2 (wam-store-value wam d2)))
+ (when (not (constants-match-p c1 c2))
+ (backtrack! wam))))
- ;; Otherwise if they're both lists, make sure their contents match.
- ((and (cell-list-p cell-1) (cell-list-p cell-2))
- (wam-unification-stack-push! wam (cell-value cell-1))
- (wam-unification-stack-push! wam (cell-value cell-2))
- (wam-unification-stack-push! wam (1+ (cell-value cell-1)))
- (wam-unification-stack-push! wam (1+ (cell-value cell-2))))
+ ;; Otherwise if they're both lists, unify their contents.
+ ((and (cell-type= t1 :list)
+ (cell-type= t2 :list))
+ (wam-unification-stack-push! wam (wam-store-value wam d1))
+ (wam-unification-stack-push! wam (wam-store-value wam d2))
+ (wam-unification-stack-push! wam (1+ (wam-store-value wam d1)))
+ (wam-unification-stack-push! wam (1+ (wam-store-value wam d2))))
- ;; Otherwise if they're both structure cells, make sure they match
- ;; and then schedule their subterms to be unified.
- ((and (cell-structure-p cell-1) (cell-structure-p cell-2))
- (let* ((structure-1-addr (cell-value cell-1)) ; find where they
- (structure-2-addr (cell-value cell-2)) ; start on the heap
- (functor-1 (wam-store-cell wam structure-1-addr)) ; grab the
- (functor-2 (wam-store-cell wam structure-2-addr))) ; functors
- (if (functors-match-p functor-1 functor-2)
- ;; If the functors match, push their pairs of arguments onto
- ;; the stack to be unified.
- (loop :with arity = (wam-functor-arity wam (cell-value functor-1))
- :for i :from 1 :to arity :do
- (wam-unification-stack-push! wam (+ structure-1-addr i))
- (wam-unification-stack-push! wam (+ structure-2-addr i)))
- ;; Otherwise we're hosed.
- (backtrack! wam))))
+ ;; Otherwise if they're both structures, make sure they match and
+ ;; then schedule their subterms to be unified.
+ ((and (cell-type= t1 :structure)
+ (cell-type= t2 :structure))
+ (let* ((s1 (wam-store-value wam d1)) ; find where they
+ (s2 (wam-store-value wam d2)) ; start on the heap
+ (f1 (wam-store-value wam s1)) ; grab the
+ (f2 (wam-store-value wam s2))) ; functors
+ (if (functors-match-p f1 f2)
+ ;; If the functors match, push their pairs of arguments onto
+ ;; the stack to be unified.
+ (loop :with arity = (wam-functor-arity wam f1)
+ :for i :from 1 :to arity :do
+ (wam-unification-stack-push! wam (+ s1 i))
+ (wam-unification-stack-push! wam (+ s2 i)))
+ ;; Otherwise we're hosed.
+ (backtrack! wam))))
- ;; Otherwise we're looking at two different kinds of cells, and are
- ;; just totally hosed. Backtrack.
- (t (backtrack! wam))))))))
+ ;; Otherwise we're looking at two different kinds of cells, and are
+ ;; just totally hosed. Backtrack.
+ (t (backtrack! wam)))))))
;;;; Instruction Definition
@@ -287,16 +259,25 @@
;;; compile we can just pick the appropriate opcode, and now we no longer need
;;; a runtime test for every single register assignment.
;;;
-;;; To make the process of defining these two "variants" we have these two
-;;; macros. `define-instruction` (singular) is just a little sugar around
-;;; `defun*`, for those instructions that don't deal with arguments.
+;;; To make the process of defining these two "variants" less excruciating we
+;;; have these two macros. `define-instruction` (singular) is just a little
+;;; sugar around `defun*`, for those instructions that don't deal with
+;;; arguments.
;;;
;;; `define-instructions` (plural) is the awful one. You pass it a pair of
;;; symbols for the two variant names. Two functions will be defined, both with
-;;; the same body, with the symbol `%wam-register%` macroletted to the
-;;; appropriate access code. So in the body, instead of using
-;;; `(wam-{local/argument}-register wam register)` you just use
-;;; `(%wam-register% wam register)` and it'll do the right thing.
+;;; the same body, with a few symbols macroletted to the appropriate access
+;;; code.
+;;;
+;;; So in the body, instead of using:
+;;;
+;;; (wam-set-{local/stack}-register wam reg type value)
+;;;
+;;; you use:
+;;;
+;;; (%wam-set-register% wam reg type value)
+;;;
+;;; and it'll do the right thing.
(defmacro define-instruction
((name &optional should-inline) lambda-list &body body)
@@ -315,11 +296,27 @@
"Define a local/stack pair of instructions."
`(progn
(macrolet ((%wam-register% (wam register)
- `(wam-local-register ,wam ,register)))
+ `(wam-local-register-address ,wam ,register))
+ (%wam-register-type% (wam register)
+ `(wam-local-register-type ,wam ,register))
+ (%wam-register-value% (wam register)
+ `(wam-local-register-value ,wam ,register))
+ (%wam-set-register% (wam register type value)
+ `(wam-set-local-register! ,wam ,register ,type ,value))
+ (%wam-copy-to-register% (wam register source)
+ `(wam-copy-to-local-register! ,wam ,register ,source)))
(define-instruction (,local-name ,should-inline) ,lambda-list
,@body))
(macrolet ((%wam-register% (wam register)
- `(wam-stack-register ,wam ,register)))
+ `(wam-stack-register-address ,wam ,register))
+ (%wam-register-type% (wam register)
+ `(wam-stack-register-type ,wam ,register))
+ (%wam-register-value% (wam register)
+ `(wam-stack-register-value ,wam ,register))
+ (%wam-set-register% (wam register type value)
+ `(wam-set-stack-register! ,wam ,register ,type ,value))
+ (%wam-copy-to-register% (wam register source)
+ `(wam-copy-to-stack-register! ,wam ,register ,source)))
(define-instruction (,stack-name ,should-inline) ,lambda-list
,@body))))
@@ -329,120 +326,115 @@
((wam wam)
(functor functor-index)
(register register-index))
- (setf (wam-local-register wam register)
- (make-cell-structure
- (nth-value 1 (push-new-functor! wam functor)))
+ (wam-set-local-register! wam register
+ +cell-type-structure+
+ (push-new-functor! wam functor))
+ (setf (wam-mode wam) :write))
- (wam-mode wam)
- :write))
-
-(define-instruction (%put-list t)
+(define-instruction (%put-list)
((wam wam)
(register register-index))
- (setf (wam-local-register wam register)
- (make-cell-list (wam-heap-pointer wam))
-
- (wam-mode wam)
- :write))
+ (wam-set-local-register! wam register
+ +cell-type-list+
+ (wam-heap-pointer wam))
+ (setf (wam-mode wam) :write))
(define-instructions (%put-variable-local %put-variable-stack)
((wam wam)
(register register-index)
(argument register-index))
- (let ((new-reference (push-unbound-reference! wam)))
- (setf (%wam-register% wam register) new-reference
- (wam-local-register wam argument) new-reference
- (wam-mode wam) :write)))
+ (let ((ref (push-unbound-reference! wam)))
+ (%wam-copy-to-register% wam register ref)
+ (wam-copy-to-local-register! wam argument ref)
+ (setf (wam-mode wam) :write)))
-(define-instructions (%put-value-local %put-value-stack t)
+(define-instructions (%put-value-local %put-value-stack)
((wam wam)
(register register-index)
(argument register-index))
- (setf (wam-local-register wam argument) (%wam-register% wam register)
- (wam-mode wam) :write))
+ (wam-copy-to-local-register! wam argument (%wam-register% wam register))
+ (setf (wam-mode wam) :write))
;;;; Program Instructions
(define-instruction (%get-structure) ((wam wam)
(functor functor-index)
(register register-index))
- (with-accessors ((mode wam-mode) (s wam-subterm)) wam
- (with-cell (addr cell) wam register
- (cond
- ;; If the register points at a reference cell, we push two new cells
- ;; onto the heap:
- ;;
- ;; | N | STR | N+1 |
- ;; | N+1 | FUN | f/n |
- ;; | | | | <- S
- ;;
- ;; Then we bind this reference cell to point at the new structure, set
- ;; the S register to point beneath it and flip over to write mode.
- ;;
- ;; It seems a bit confusing that we don't push the rest of the structure
- ;; stuff on the heap after it too. But that's going to happen in the
- ;; next few instructions (which will be subterm-*'s, executed in write
- ;; mode).
- ((cell-reference-p cell)
- (let ((structure-address (nth-value 1 (push-new-structure! wam)))
- (functor-address (nth-value 1 (push-new-functor! wam functor))))
- (bind! wam addr structure-address)
- (setf mode :write
- s (1+ functor-address))))
+ (cell-typecase (wam (deref wam register) address)
+ ;; If the register points at an unbound reference cell, we push two new
+ ;; cells onto the heap:
+ ;;
+ ;; | N | STR | N+1 |
+ ;; | N+1 | FUN | f/n |
+ ;; | | | | <- S
+ ;;
+ ;; Then we bind this reference cell to point at the new structure, set
+ ;; the S register to point beneath it and flip over to write mode.
+ ;;
+ ;; It seems a bit confusing that we don't push the rest of the structure
+ ;; stuff on the heap after it too. But that's going to happen in the
+ ;; next few instructions (which will be subterm-*'s, executed in write
+ ;; mode).
+ (:reference
+ (let ((structure-address (push-new-structure! wam))
+ (functor-address (push-new-functor! wam functor)))
+ (bind! wam address structure-address)
+ (setf (wam-mode wam) :write
+ (wam-subterm wam) (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):
- ;;
- ;; | N | STR | M | points at the structure, not necessarily contiguous
- ;; | ... |
- ;; | M | FUN | f/2 | the functor (hopefully it matches)
- ;; | M+1 | ... | ... | pieces of the structure, always contiguous
- ;; | M+2 | ... | ... | and always right after the functor
- ;;
- ;; If it matches the functor we're looking for, we can proceed. We set
- ;; the S register to the address of the first subform we need to match
- ;; (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.
- ((cell-structure-p cell)
- (let* ((functor-address (cell-value cell))
- (functor-cell (wam-heap-cell wam functor-address)))
- (if (matching-functor-p functor-cell functor)
- (setf mode :read
- s (1+ functor-address))
- (backtrack! wam))))
+ ;; 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
+ ;; | ... |
+ ;; | M | FUN | f/2 | the functor (hopefully it matches)
+ ;; | M+1 | ... | ... | pieces of the structure, always contiguous
+ ;; | M+2 | ... | ... | and always right after the functor
+ ;;
+ ;; If it matches the functor we're looking for, we can proceed. We set
+ ;; the S register to the address of the first subform we need to match
+ ;; (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.
+ ((:structure functor-address)
+ (cell-typecase (wam functor-address)
+ ((:functor f)
+ (if (functors-match-p functor f)
+ (setf (wam-mode wam) :read
+ (wam-subterm wam) (1+ functor-address))
+ (backtrack! wam)))))
- (t (backtrack! wam))))))
+ ;; Otherwise we can't unify, so backtrack.
+ (t (backtrack! wam))))
(define-instruction (%get-list) ((wam wam)
(register register-index))
- (with-cell (addr cell) wam register
- (cond
- ;; If the register points at a reference (unbound, because we deref'ed) we
- ;; bind it to a list and flip into write mode to write the upcoming two
- ;; things as its contents.
- ((cell-reference-p cell)
- (bind! wam addr (nth-value 1 (push-new-list! wam)))
- (setf (wam-mode wam) :write))
+ (cell-typecase (wam (deref wam register) address)
+ ;; If the register points at a reference (unbound, because we deref'ed) we
+ ;; bind it to a list and flip into write mode to write the upcoming two
+ ;; things as its contents.
+ (:reference
+ (bind! wam address (push-new-list! wam))
+ (setf (wam-mode wam) :write))
- ;; If this is a list, we need to unify its subterms.
- ((cell-list-p cell)
- (setf (wam-mode wam) :read
- (wam-subterm wam) (cell-value cell)))
+ ;; If this is a list, we need to unify its subterms.
+ ((:list contents)
+ (setf (wam-mode wam) :read
+ (wam-subterm wam) contents))
- (t (backtrack! wam)))))
+ ;; Otherwise we can't unify.
+ (t (backtrack! wam))))
-(define-instructions (%get-variable-local %get-variable-stack t)
+(define-instructions (%get-variable-local %get-variable-stack)
((wam wam)
(register register-index)
(argument register-index))
- (setf (%wam-register% wam register)
- (wam-local-register wam argument)))
+ (%wam-copy-to-register% wam register argument))
-(define-instructions (%get-value-local %get-value-stack)
+(define-instructions (%get-value-local %get-value-stack t)
((wam wam)
(register register-index)
(argument register-index))
@@ -453,10 +445,10 @@
(define-instructions (%subterm-variable-local %subterm-variable-stack)
((wam wam)
(register register-index))
- (setf (%wam-register% wam register)
- (ecase (wam-mode wam)
- (:read (wam-heap-cell wam (wam-subterm wam)))
- (:write (push-unbound-reference! wam))))
+ (%wam-copy-to-register% wam register
+ (ecase (wam-mode wam)
+ (:read (wam-subterm wam))
+ (:write (push-unbound-reference! wam))))
(incf (wam-subterm wam)))
(define-instructions (%subterm-value-local %subterm-value-stack)
@@ -464,7 +456,9 @@
(register register-index))
(ecase (wam-mode wam)
(:read (unify! wam register (wam-subterm wam)))
- (:write (wam-heap-push! wam (%wam-register% wam register))))
+ (:write (wam-heap-push! wam
+ (%wam-register-type% wam register)
+ (%wam-register-value% wam register))))
(incf (wam-subterm wam)))
(define-instruction (%subterm-void) ((wam wam) (n arity))
@@ -482,7 +476,7 @@
(functor functor)
(program-counter-increment instruction-size)
(is-tail boolean))
- (let* ((findex (wam-ensure-functor-index wam functor))
+ (let* ((findex (wam-ensure-functor-index wam functor)) ; todo unfuck this once we finish splitting
(target (wam-code-label wam findex)))
(if (not target)
;; Trying to call an unknown procedure.
@@ -506,31 +500,30 @@
(%%procedure-call
wam functor (instruction-size +opcode-dynamic-jump+) t)
(%%procedure-call
- wam functor (instruction-size +opcode-dynamic-call+) nil))))
- (with-cell (addr cell) wam 0 ; A_0
- (cond
- ((cell-structure-p cell)
- (with-cell (functor-address functor-cell) wam (cell-value cell)
- (let ((functor (cell-value functor-cell)))
- ;; If we have a non-zero-arity structure, we need to set up the
- ;; argument registers before we call it. Luckily all the arguments
- ;; conveniently live contiguously right after the functor cell.
- (loop :with arity = (wam-functor-arity wam functor)
- :for argument-register :from 0 :below arity
- :for argument-address :from (1+ functor-address)
- :do (setf (wam-local-register wam argument-register)
- (wam-heap-cell wam argument-address)))
- (%go (wam-functor-lookup wam functor)))))
- ((cell-constant-p cell)
- ;; Zero-arity functors don't need to set up anything at all -- we can
- ;; just call them immediately.
- (%go (wam-functor-lookup wam (cell-value cell))))
- ((cell-reference-p cell)
- ;; It's okay to do (call :var), but :var has to be bound by the time you
- ;; actually reach it at runtime.
- (error "Cannot dynamically call an unbound variable."))
- (t ; You can't (call) anything else.
- (error "Cannot dynamically call something other than a structure."))))))
+ wam functor (instruction-size +opcode-dynamic-call+) nil)))
+ (load-arguments (n start-address)
+ (loop :for arg :from 0 :below n
+ :for source :from start-address
+ :do (wam-copy-to-local-register! wam arg source))))
+ (cell-typecase (wam (deref wam 0)) ; A_0
+ ((:structure functor-address)
+ ;; If we have a non-zero-arity structure, we need to set up the
+ ;; argument registers before we call it. Luckily all the arguments
+ ;; conveniently live contiguously right after the functor cell.
+ (cell-typecase (wam functor-address)
+ ((:functor f)
+ (load-arguments (wam-functor-arity wam f) (1+ functor-address))
+ (%go (wam-functor-lookup wam f)))))
+ ((:constant c)
+ ;; Zero-arity functors don't need to set up anything at all -- we can
+ ;; just call them immediately.
+ (%go (wam-functor-lookup wam c)))
+ (:reference
+ ;; It's okay to do (call :var), but :var has to be bound by the time you
+ ;; actually reach it at runtime.
+ (error "Cannot dynamically call an unbound variable."))
+ (t ; You can't call/1 anything else.
+ (error "Cannot dynamically call something other than a structure.")))))
(define-instruction (%jump) ((wam wam) (functor functor))
@@ -590,6 +583,12 @@
+heap-start+
(wam-stack-choice-h wam b))))
+(defun* restore-registers-from-choice-point! ((wam wam)
+ (b backtrack-pointer))
+ (loop :for register :from 0 :below (wam-stack-choice-n wam b)
+ :for saved-register :from (wam-stack-choice-argument-address wam 0 b)
+ :do (wam-copy-to-local-register! wam register saved-register)))
+
(define-instruction (%try) ((wam wam) (next-clause code-index))
(let ((new-b (wam-stack-top wam))
@@ -605,16 +604,13 @@
(wam-stack-word wam (+ new-b 7)) (wam-cut-pointer wam) ; CC
(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
- (setf (wam-stack-choice-arg wam i new-b)
- (wam-local-register wam i)))))
+ (loop :for i :from 0 :below nargs ; A_i
+ :for n :from 0 :below nargs ; arg N in the choice point frame
+ :do (wam-copy-to-stack-choice-argument! wam n i new-b))))
(define-instruction (%retry) ((wam wam) (next-clause code-index))
(let ((b (wam-backtrack-pointer wam)))
- ;; Restore argument registers
- (loop :for i :from 0 :below (wam-stack-choice-n wam b) :do
- (setf (wam-local-register wam i)
- (wam-stack-choice-arg wam i b)))
+ (restore-registers-from-choice-point! wam b)
(unwind-trail! wam (wam-stack-choice-tr wam b) (wam-trail-pointer wam))
(setf (wam-environment-pointer wam) (wam-stack-choice-ce wam b)
(wam-continuation-pointer wam) (wam-stack-choice-cp wam b)
@@ -627,10 +623,7 @@
(define-instruction (%trust) ((wam 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)
- (wam-stack-choice-arg wam i b)))
+ (restore-registers-from-choice-point! wam b)
(unwind-trail! wam (wam-stack-choice-tr wam b) (wam-trail-pointer wam))
(setf (wam-environment-pointer wam) (wam-stack-choice-ce wam b)
(wam-continuation-pointer wam) (wam-stack-choice-cp wam b)
@@ -650,41 +643,42 @@
(declaim (inline %%match-constant))
-(defun* %%match-constant ((wam wam)
- (constant functor-index)
- (address store-index))
- (with-cell (addr cell) wam address
- (cond
- ((cell-reference-p cell)
- (setf (wam-store-cell wam addr)
- (make-cell-constant constant))
- (trail! wam addr))
+(defun* %%match-constant
+ ((wam wam)
+ (constant functor-index)
+ (address store-index))
+ (cell-typecase (wam (deref wam address) address)
+ (:reference
+ (wam-set-store-cell! wam address +cell-type-constant+ constant)
+ (trail! wam address))
- ((cell-constant-p cell)
- (when (not (= constant (cell-value cell)))
- (backtrack! wam)))
+ ((:constant c)
+ (when (not (= constant c))
+ (backtrack! wam)))
- (t
- (backtrack! wam)))))
+ (t (backtrack! wam))))
-(define-instruction (%put-constant t)
+(define-instruction (%put-constant)
((wam wam)
(constant functor-index)
(register register-index))
- (setf (wam-local-register wam register) (make-cell-constant constant)
- (wam-mode wam) :write))
+ (wam-set-local-register! wam register +cell-type-constant+ constant)
+ ; todo we can probably elide this because constants never have subterms...
+ (setf (wam-mode wam) :write))
-(define-instruction (%get-constant) ((wam wam)
- (constant functor-index)
- (register register-index))
+(define-instruction (%get-constant)
+ ((wam wam)
+ (constant functor-index)
+ (register register-index))
(%%match-constant wam constant register))
-(define-instruction (%subterm-constant) ((wam wam)
- (constant functor-index))
+(define-instruction (%subterm-constant)
+ ((wam wam)
+ (constant functor-index))
(ecase (wam-mode wam)
(:read (%%match-constant wam constant (wam-subterm wam)))
- (:write (wam-heap-push! wam (make-cell-constant constant))))
+ (:write (push-new-constant! wam constant)))
(incf (wam-subterm wam)))
@@ -716,30 +710,27 @@
(let ((unbound-vars (list)))
(labels
((mark-unbound-var (address)
- (let ((symbol (make-symbol (format nil "var-~D" ; lol
+ (let ((symbol (make-symbol (format nil "?VAR-~D" ; lol
(length unbound-vars)))))
(car (push (cons address symbol) unbound-vars))))
(extract-var (address)
(cdr (or (assoc address unbound-vars)
(mark-unbound-var address))))
(recur (address)
- (let ((cell (wam-store-cell wam (deref wam address))))
- (cond
- ((cell-null-p cell) "NULL?!")
- ((cell-reference-p cell) (extract-var (cell-value cell)))
- ((cell-structure-p cell) (recur (cell-value cell)))
- ((cell-list-p cell) (cons (recur (cell-value cell))
- (recur (1+ (cell-value cell)))))
- ((cell-constant-p cell)
- (wam-functor-symbol wam (cell-value cell)))
- ((cell-functor-p cell)
- (destructuring-bind (functor . arity)
- (wam-functor-lookup wam (cell-value cell))
- (list* functor
- (loop :for addr
- :from (+ address 1) :below (+ address arity 1)
- :collect (recur addr)))))
- (t (error "What to heck is this?"))))))
+ (cell-typecase (wam (deref wam address) address)
+ (:null "NULL?!")
+ ((:reference r) (extract-var r))
+ ((:structure s) (recur s))
+ ((:list l) (cons (recur l) (recur (1+ l))))
+ ((:constant c) (wam-functor-symbol wam c))
+ ((:functor f)
+ (destructuring-bind (functor . arity)
+ (wam-functor-lookup wam f)
+ (list* functor
+ (loop :repeat arity
+ :for subterm :from (+ address 1)
+ :collect (recur subterm)))))
+ (t (error "What to heck is this?")))))
(mapcar #'recur addresses))))
(defun extract-query-results (wam vars)
--- a/src/wam/wam.lisp Tue Jul 12 21:56:01 2016 +0000
+++ b/src/wam/wam.lisp Wed Jul 13 18:33:09 2016 +0000
@@ -10,8 +10,8 @@
:initial-element 0
:element-type 'code-word))
-(defun allocate-wam-store (size)
- ;; The main WAM store contains three separate blocks of values:
+(defun allocate-wam-type-store (size)
+ ;; The main WAM store(s) contain three separate blocks of values:
;;
;; [0, +register-count+) -> the local X_n registers
;; [+stack-start+, +stack-end+) -> the stack
@@ -21,9 +21,16 @@
;; `+stack-end+` and `+heap-start+` are the same number as well.
(make-array (+ +register-count+
+stack-limit+
+ size) ; type array
+ :initial-element +cell-type-null+
+ :element-type 'cell-type))
+
+(defun allocate-wam-value-store (size)
+ (make-array (+ +register-count+
+ +stack-limit+
size)
- :initial-element (make-cell-null)
- :element-type 'cell))
+ :initial-element 0
+ :element-type 'cell-value))
(defstruct (wam
@@ -34,9 +41,13 @@
(wam stream :type t :identity t)
(format stream "an wam"))))
(:constructor make-wam%))
- (store
- (allocate-wam-store 0)
- :type store
+ (type-store
+ (allocate-wam-type-store 0)
+ :type type-store
+ :read-only t)
+ (value-store
+ (allocate-wam-value-store 0)
+ :type value-store
:read-only t)
(code
(allocate-wam-code 0)
@@ -93,31 +104,180 @@
(mode nil :type (or null (member :read :write))))
-(defun* make-wam (&key (store-size (megabytes 10))
- (code-size (megabytes 1)))
+(defun* make-wam (&key
+ (store-size (megabytes 10))
+ (code-size (megabytes 1)))
(:returns wam)
(make-wam% :code (allocate-wam-code code-size)
- :store (allocate-wam-store store-size)))
+ :type-store (allocate-wam-type-store store-size)
+ :value-store (allocate-wam-value-store store-size)))
;;;; Store
-(declaim (inline wam-store-cell (setf wam-store-cell)))
+;;; The main store of the WAM is split into two separate arrays:
+;;;
+;;; * An array of cell types, packed into 4-bit bytes.
+;;; * An array of cell values, each being a fixnum or a normal Lisp pointer.
+;;;
+;;; The contents of the value depend on the type of cell.
+;;;
+;;; NULL cells always have a value of zero.
+;;;
+;;; STRUCTURE cell values are an index into the store, describing where the
+;;; structure starts.
+;;;
+;;; REFERENCE cell values are an index into the store, pointing at whatever the
+;;; value is bound to. Unbound variables contain their own store index as
+;;; a value.
+;;;
+;;; FUNCTOR cell values are an index into the WAM's functor array where the
+;;; `(symbol . arity)` cons lives.
+;;;
+;;; CONSTANT cells are the same as functor cells, except that they always happen
+;;; to refer to functors with an arity of zero.
+;;;
+;;; LIST cell values are an index into the store, pointing at the first of two
+;;; consecutive cells. The first cell is the car of the list, the second one is
+;;; the cdr.
+;;;
+;;; STACK cell values are special cases. The WAM's main store is a combination
+;;; of the heap, the stack, and registers. Heap cells (and registers) are those
+;;; detailed above, but stack cells can also hold numbers like the continuation
+;;; pointer. We lump all the extra things together into one kind of cell.
+
+(declaim (inline wam-store-type
+ wam-store-value
+ wam-set-store-cell!
+ wam-copy-store-cell!))
+
+
+(defun* wam-store-type ((wam wam) (address store-index))
+ (:returns cell-type)
+ "Return the type of the cell at the given address."
+ (aref (wam-type-store wam) address))
+
+(defun* wam-store-value ((wam wam) (address store-index))
+ (:returns cell-value)
+ "Return the value of the cell at the given address."
+ (aref (wam-value-store wam) address))
+
+
+(defun* wam-set-store-cell! ((wam wam)
+ (address store-index)
+ (type cell-type)
+ (value cell-value))
+ (setf (aref (wam-type-store wam) address) type
+ (aref (wam-value-store wam) address) value))
+
+(defun* wam-copy-store-cell! ((wam wam)
+ (destination store-index)
+ (source store-index))
+ (wam-set-store-cell! wam
+ destination
+ (wam-store-type wam source)
+ (wam-store-value wam source)))
+
+
+(defun* wam-sanity-check-store-read ((wam wam) (address store-index))
+ (declare (ignore wam))
+ (when (= address +heap-start+)
+ (error "Cannot read from heap address zero.")))
-(defun* wam-store-cell ((wam wam) (address store-index))
- (:returns cell)
- "Return the cell at the given address.
+(macrolet ((define-unsafe (name return-type)
+ `(progn
+ (declaim (inline ,name))
+ (defun* ,name ((wam wam) (address store-index))
+ (:returns ,return-type)
+ (aref (wam-value-store wam) address)))))
+ (define-unsafe %unsafe-null-value (eql 0))
+ (define-unsafe %unsafe-structure-value store-index)
+ (define-unsafe %unsafe-reference-value store-index)
+ (define-unsafe %unsafe-functor-value store-index)
+ (define-unsafe %unsafe-constant-value store-index)
+ (define-unsafe %unsafe-list-value store-index)
+ (define-unsafe %unsafe-stack-value stack-word))
+
+
+(defun %type-designator-constant (designator)
+ (ecase designator
+ (:null +cell-type-null+)
+ (:structure +cell-type-structure+)
+ (:reference +cell-type-reference+)
+ (:functor +cell-type-functor+)
+ (:constant +cell-type-constant+)
+ (:list +cell-type-list+)
+ ((t) t)))
- Please don't use this unless you absolutely have to. Prefer something more
- specific like `wam-heap-cell` else so you've got some extra sanity checking...
+(defun %type-designator-accessor (designator)
+ (ecase designator
+ (:null '%unsafe-null-value)
+ (:structure '%unsafe-structure-value)
+ (:reference '%unsafe-reference-value)
+ (:functor '%unsafe-functor-value)
+ (:constant '%unsafe-constant-value)
+ (:list '%unsafe-list-value)))
+
+
+(defmacro cell-typecase ((wam address &optional address-symbol) &rest clauses)
+ "Dispatch on the type of the cell at `address` in the WAM store.
+
+ If `address-symbol` is given it will be bound to the result of evaluating
+ `address` in the remainder of the form.
+
+ The type of the cell will be matched against `clauses` much like `typecase`.
+
+ Each clause should be of the form `(binding forms)`.
+
+ Each binding can be either a simple cell type designator like `:reference`, or
+ a list of this designator and a symbol to bind the cell's value to. The
+ symbol is bound with `let` around the `forms` and type-hinted appropriately
+ (at least on SBCL).
+
+ Example:
+
+ (cell-typecase (wam (deref wam address) final-address)
+ (:reference (bind final-address foo)
+ 'it-is-a-reference)
+ ((:constant c) (list 'it-is-the-constant c))
+ (t 'unknown))
"
- (aref (wam-store wam) address))
+ (once-only (wam address)
+ (labels
+ ((normalize-binding (binding)
+ (cond
+ ((symbolp binding) (list binding nil))
+ ((= 1 (length binding)) (list (car binding) nil))
+ (t binding)))
+ (parse-clause (clause)
+ (destructuring-bind (binding . body) clause
+ (destructuring-bind (type-designator value-symbol)
+ (normalize-binding binding)
+ `(,(%type-designator-constant type-designator)
+ (let (,@(when value-symbol
+ (list
+ `(,value-symbol
+ (,(%type-designator-accessor type-designator)
+ ,wam ,address)))))
+ ,@body))))))
+ `(progn
+ (policy-cond:policy-if (or (= safety 3) (= debug 3))
+ (wam-sanity-check-store-read ,wam ,address)
+ nil)
+ (let (,@(when address-symbol
+ (list `(,address-symbol ,address))))
+ (case (wam-store-type ,wam ,address)
+ ,@(mapcar #'parse-clause clauses)))))))
-(defun* (setf wam-store-cell) ((new-value cell)
- (wam wam)
- (address store-index))
- (setf (aref (wam-store wam) address) new-value))
+
+(defmacro cell-type= (type type-designator)
+ `(= ,type ,(%type-designator-constant type-designator)))
+
+(defmacro cell-type-p ((wam address) type-designator)
+ `(cell-type=
+ (wam-store-type ,wam ,address)
+ ,type-designator))
;;;; Heap
@@ -128,12 +288,7 @@
;;; We reserve the first address in the heap as a sentinel, as an "unset" value
;;; for various pointers into the heap.
-(declaim (inline wam-heap-pointer-unset-p
- wam-heap-cell
- (setf wam-heap-cell)
- wam-heap-pointer
- (setf wam-heap-pointer)
- wam-heap-push!))
+(declaim (inline wam-heap-pointer-unset-p wam-heap-push!))
(defun* wam-heap-pointer-unset-p ((wam wam) (address heap-index))
@@ -141,36 +296,27 @@
(declare (ignore wam))
(= address +heap-start+))
-
-(defun* wam-heap-push! ((wam wam) (cell cell))
- (:returns (values cell heap-index))
+(defun* wam-heap-push! ((wam wam) (type cell-type) (value cell-value))
+ (:returns heap-index)
"Push the cell onto the WAM heap and increment the heap pointer.
- Returns the cell and the address it was pushed to.
+ Returns the address it was pushed to.
"
- (if (>= (wam-heap-pointer wam) +store-limit+) ; todo: respect actual size...
- (error "WAM heap exhausted.")
- (values cell (array-push cell (wam-store wam) (wam-heap-pointer wam)))))
-
-
-(defun* wam-heap-cell ((wam wam) (address heap-index))
- (:returns cell)
- "Return the heap cell at the given address."
- (when (wam-heap-pointer-unset-p wam address)
- (error "Cannot read from heap address zero."))
- (aref (wam-store wam) address))
-
-(defun* (setf wam-heap-cell) ((new-value cell)
- (wam wam)
- (address heap-index))
- (when (wam-heap-pointer-unset-p wam address)
- (error "Cannot write to heap address zero."))
- (setf (aref (wam-store wam) address) new-value))
+ (let ((heap-pointer (wam-heap-pointer wam)))
+ (if (>= heap-pointer +store-limit+) ; todo: respect actual size...
+ (error "WAM heap exhausted.")
+ (progn
+ (wam-set-store-cell! wam heap-pointer type value)
+ (incf (wam-heap-pointer wam))
+ heap-pointer))))
;;;; Trail
-(declaim (inline wam-trail-pointer (setf wam-trail-pointer)))
+(declaim (inline wam-trail-pointer
+ (setf wam-trail-pointer)
+ wam-trail-value
+ (setf wam-trail-value)))
(defun* wam-trail-pointer ((wam wam))
@@ -255,13 +401,13 @@
(:returns stack-word)
"Return the stack word at the given address."
(assert-inside-stack wam address)
- (aref (wam-store wam) address))
+ (%unsafe-stack-value wam address))
(defun* (setf wam-stack-word) ((new-value stack-word)
(wam wam)
(address stack-index))
(assert-inside-stack wam address)
- (setf (aref (wam-store wam) address) new-value))
+ (wam-set-store-cell! wam address +cell-type-stack+ new-value))
(defun* wam-backtrack-pointer-unset-p
@@ -297,9 +443,10 @@
wam-stack-frame-cp
wam-stack-frame-cut
wam-stack-frame-n
- wam-stack-frame-arg
- (setf wam-stack-frame-arg)
- wam-stack-frame-size))
+ wam-stack-frame-size
+ wam-stack-frame-argument-address
+ wam-set-stack-frame-argument!))
+
(defun* wam-stack-frame-ce
((wam wam)
@@ -334,22 +481,33 @@
(wam-stack-word wam (+ 3 e)))
-(defun* wam-stack-frame-arg
+(defun* wam-stack-frame-argument-address
((wam wam)
(n register-index)
&optional
((e environment-pointer)
(wam-environment-pointer wam)))
- (:returns cell)
- (wam-stack-word wam (+ 4 n e)))
+ (:returns stack-index)
+ (+ 4 n e))
-(defun* (setf wam-stack-frame-arg) ((new-value cell)
- (wam wam)
- (n register-index)
- &optional ((e environment-pointer)
- (wam-environment-pointer wam)))
- (setf (wam-stack-word wam (+ e 4 n))
- new-value))
+(defun* wam-set-stack-frame-argument!
+ ((wam wam)
+ (n register-index)
+ (type cell-type)
+ (value cell-value)
+ &optional ((e environment-pointer)
+ (wam-environment-pointer wam)))
+ (wam-set-store-cell! wam (wam-stack-frame-argument-address wam n e)
+ type value))
+
+(defun* wam-copy-to-stack-frame-argument!
+ ((wam wam)
+ (n register-index)
+ (source store-index)
+ &optional ((e environment-pointer)
+ (wam-environment-pointer wam)))
+ (wam-copy-store-cell! wam (wam-stack-frame-argument-address wam n e)
+ source))
(defun* wam-stack-frame-size
@@ -389,9 +547,11 @@
wam-stack-choice-bp
wam-stack-choice-tr
wam-stack-choice-h
- wam-stack-choice-arg
- (setf wam-stack-choice-arg)
- wam-stack-choice-size))
+ wam-stack-choice-size
+ wam-stack-choice-argument-address
+ wam-set-stack-choice-argument!
+ wam-copy-to-stack-choice-argument!))
+
(defun* wam-stack-choice-n
((wam wam)
@@ -458,29 +618,38 @@
(wam-stack-word wam (+ b 7)))
-(defun* wam-stack-choice-arg
+(defun* wam-stack-choice-argument-address
+ ((wam wam)
+ (n register-index)
+ &optional ((b backtrack-pointer)
+ (wam-backtrack-pointer wam)))
+ (:returns stack-index)
+ (+ 8 n b))
+
+(defun* wam-set-stack-choice-argument!
((wam wam)
- (n arity)
- &optional
- ((b backtrack-pointer)
- (wam-backtrack-pointer wam)))
- (:returns cell)
- (wam-stack-word wam (+ b 8 n)))
+ (n register-index)
+ (type cell-type)
+ (value cell-value)
+ &optional ((b backtrack-pointer)
+ (wam-backtrack-pointer wam)))
+ (wam-set-store-cell! wam (wam-stack-choice-argument-address wam n b)
+ type value))
-(defun* (setf wam-stack-choice-arg) ((new-value cell)
- (wam wam)
- (n arity)
- &optional ((b backtrack-pointer)
- (wam-backtrack-pointer wam)))
- (setf (wam-stack-word wam (+ b 8 n))
- new-value))
+(defun* wam-copy-to-stack-choice-argument!
+ ((wam wam)
+ (n register-index)
+ (source store-index)
+ &optional ((b backtrack-pointer)
+ (wam-backtrack-pointer wam)))
+ (wam-copy-store-cell! wam (wam-stack-choice-argument-address wam n b)
+ source))
(defun* wam-stack-choice-size
((wam wam)
- &optional
- ((b backtrack-pointer)
- (wam-backtrack-pointer wam)))
+ &optional ((b backtrack-pointer)
+ (wam-backtrack-pointer wam)))
(:returns stack-choice-size)
"Return the size of the choice frame starting at backtrack pointer `b`."
(+ (wam-stack-choice-n wam b) 8))
@@ -510,6 +679,7 @@
;;;; Resetting
(defun* wam-truncate-heap! ((wam wam))
+ ;; todo: null out the heap once we're storing live objects
(setf (wam-heap-pointer wam) (1+ +heap-start+)))
(defun* wam-truncate-trail! ((wam wam))
@@ -519,13 +689,15 @@
(setf (fill-pointer (wam-unification-stack wam)) 0))
(defun* wam-reset-local-registers! ((wam wam))
- (fill (wam-store wam) (make-cell-null) :start 0 :end +register-count+))
+ (fill (wam-type-store wam) +cell-type-null+ :start 0 :end +register-count+)
+ (fill (wam-value-store wam) 0 :start 0 :end +register-count+))
(defun* wam-reset! ((wam wam))
(wam-truncate-heap! wam)
(wam-truncate-trail! wam)
(wam-truncate-unification-stack! wam)
(policy-cond:policy-if (>= debug 2)
+ ;; todo we can't elide this once we start storing live objects... :(
(wam-reset-local-registers! wam)
nil) ; fuck it
(setf (wam-program-counter wam) 0
@@ -740,43 +912,71 @@
;;; / _, _/ /___/ /_/ // / ___/ // / / /___/ _, _/___/ / / ___ |/ _, _/ /___ / /___/ /___/ /___/ /______/ /
;;; /_/ |_/_____/\____/___//____//_/ /_____/_/ |_|/____/ /_/ |_/_/ |_/_____/ \____/_____/_____/_____/____/
-(declaim (inline wam-local-register
- (setf wam-local-register)
- wam-stack-register
- (setf wam-stack-register)))
+(declaim (inline wam-set-local-register!
+ wam-set-stack-register!
+ wam-local-register-address
+ wam-stack-register-address
+ wam-local-register-type
+ wam-stack-register-type
+ wam-local-register-value
+ wam-stack-register-value
+ wam-copy-to-local-register!
+ wam-copy-to-stack-register!
+ wam-local-register-address
+ wam-stack-register-address))
+
-(defun* wam-local-register ((wam wam) (register register-index))
- (:returns cell)
- "Return the value stored in the WAM local register with the given index."
- (aref (wam-store wam) register))
+(defun* wam-local-register-address ((wam wam) (register register-index))
+ (:returns store-index)
+ (declare (ignore wam))
+ register)
+
+(defun* wam-stack-register-address ((wam wam) (register register-index))
+ (:returns store-index)
+ (wam-stack-frame-argument-address wam register))
-(defun* (setf wam-local-register) ((new-value cell)
- (wam wam)
- (register register-index))
- (setf (aref (wam-store wam) register) new-value))
+
+(defun* wam-local-register-type ((wam wam) (register register-index))
+ (:returns cell-type)
+ (wam-store-type wam (wam-local-register-address wam register)))
+
+(defun* wam-stack-register-type ((wam wam) (register register-index))
+ (:returns cell-type)
+ (wam-store-type wam (wam-stack-register-address wam register)))
-(defun* wam-stack-register ((wam wam) (register register-index))
- (:returns cell)
- "Return the value stored in the WAM stack register with the given index."
- (wam-stack-frame-arg wam register))
+(defun* wam-local-register-value ((wam wam) (register register-index))
+ (:returns cell-value)
+ (wam-store-value wam (wam-local-register-address wam register)))
-(defun* (setf wam-stack-register) ((new-value cell)
- (wam wam)
- (register register-index))
- (setf (wam-stack-frame-arg wam register) new-value))
+(defun* wam-stack-register-value ((wam wam) (register register-index))
+ (:returns cell-value)
+ (wam-store-value wam (wam-stack-register-address wam register)))
-(defun* wam-s-cell ((wam wam))
- "Retrieve the cell the S register is pointing at.
-
- If S is unbound, throws an error.
+(defun* wam-set-local-register! ((wam wam)
+ (address register-index)
+ (type cell-type)
+ (value cell-value))
+ (wam-set-store-cell! wam (wam-local-register-address wam address)
+ type value))
- "
- (let ((s (wam-subterm wam)))
- (if (wam-heap-pointer-unset-p wam s)
- (error "Cannot dereference unbound S register.")
- (wam-heap-cell wam s))))
+(defun* wam-set-stack-register! ((wam wam)
+ (address register-index)
+ (type cell-type)
+ (value cell-value))
+ (wam-set-stack-frame-argument! wam address type value))
+
+
+(defun* wam-copy-to-local-register! ((wam wam)
+ (destination register-index)
+ (source store-index))
+ (wam-copy-store-cell! wam (wam-local-register-address wam destination) source))
+
+(defun* wam-copy-to-stack-register! ((wam wam)
+ (destination register-index)
+ (source store-index))
+ (wam-copy-store-cell! wam (wam-stack-register-address wam destination) source))
;;;; Functors
@@ -787,6 +987,7 @@
wam-functor-symbol
wam-functor-arity))
+
(defun* wam-ensure-functor-index ((wam wam) (functor functor))
(:returns functor-index)
"Return the index of the functor in the WAM's functor table.
@@ -815,6 +1016,11 @@
;;;; Unification Stack
+(declaim (inline wam-unification-stack-push!
+ wam-unification-stack-pop!
+ wam-unification-stack-empty-p))
+
+
(defun* wam-unification-stack-push! ((wam wam) (address store-index))
(vector-push-extend address (wam-unification-stack wam)))
--- a/test/wam.lisp Tue Jul 12 21:56:01 2016 +0000
+++ b/test/wam.lisp Wed Jul 13 18:33:09 2016 +0000
@@ -407,11 +407,13 @@
(test anonymous-variables
(with-fresh-database
(push-logic-frame-with
+ (fact (following (s ? ? ? a)))
(fact (foo x))
(rule (bar (baz ?x ?y ?z ?thing))
(foo ?thing))
(fact (wild ? ? ?)))
(should-return
+ ((following (s x x x a)) empty)
((bar (baz a b c no)) fail)
((bar (baz a b c ?what)) (?what x))
((wild a b c) empty))))