# HG changeset patch # User Steve Losh # Date 1468434789 0 # Node ID 31305584b29bc7df3c499f895c44f3f7cdc40b83 # Parent 184e610451c0693356c9930e3300d730ad8ac9bd Split apart the main WAM store into separate type/value arrays Still need to actually start *using* this. diff -r 184e610451c0 -r 31305584b29b .lispwords --- 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) diff -r 184e610451c0 -r 31305584b29b bones.asd --- 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") diff -r 184e610451c0 -r 31305584b29b src/wam/bytecode.lisp --- 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")) + diff -r 184e610451c0 -r 31305584b29b src/wam/cells.lisp --- 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)) - - diff -r 184e610451c0 -r 31305584b29b src/wam/constants.lisp --- 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.") diff -r 184e610451c0 -r 31305584b29b src/wam/dump.lisp --- 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{#~;~}"))) + + +(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)) - - diff -r 184e610451c0 -r 31305584b29b src/wam/types.lisp --- 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) - - diff -r 184e610451c0 -r 31305584b29b src/wam/vm.lisp --- 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) diff -r 184e610451c0 -r 31305584b29b src/wam/wam.lisp --- 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))) diff -r 184e610451c0 -r 31305584b29b test/wam.lisp --- 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))))