--- a/src/wam/compiler.lisp Wed Jul 13 18:33:09 2016 +0000
+++ b/src/wam/compiler.lisp Wed Jul 13 22:21:19 2016 +0000
@@ -134,6 +134,7 @@
(tail :accessor node-tail :type node :initarg :tail)))
+; todo functor -> fname
(defun* make-top-level-node ((functor symbol) (arity arity) (arguments list))
(:returns top-level-node)
(values (make-instance 'top-level-node
@@ -1126,7 +1127,7 @@
;; OP functor reg
(push destination-register seen)
(push-instruction (find-opcode-structure mode)
- (wam-ensure-functor-index wam (cons functor arity))
+ (wam-unique-functor wam (cons functor arity))
destination-register))
(handle-list (register)
(push register seen)
@@ -1142,7 +1143,7 @@
;; [CALL/JUMP] functor
(push-instruction
(if is-jump :jump :call)
- (cons functor arity)))
+ (wam-unique-functor wam (cons functor arity))))
;; This is a little janky, but at this point the body goals have been
;; turned into one single stream of tokens, so we don't have a nice
;; clean way to tell when one ends. But in practice, a body goal is
@@ -1392,10 +1393,11 @@
(defun* optimize-constants ((wam wam) (instructions circle))
(:returns circle)
+ (declare (ignore wam))
;; From the book and the erratum, there are four optimizations we can do for
;; constants (0-arity structures).
(flet ((constant-p (functor)
- (zerop (wam-functor-arity wam functor))))
+ (zerop (cdr functor))))
(loop :for node = (circle-forward instructions) :then (circle-forward node)
:while node
:for (opcode . arguments) = (circle-value node)
@@ -1525,7 +1527,7 @@
;; todo: simplify this to a single `if` once the store is fully split
(null 0) ; ugly choice point args that'll be filled later...
(register (register-number argument)) ; bytecode just needs register numbers
- (functor argument) ; functor for a CALL/JUMP
+ (functor argument) ; functors just get literally included
(number argument))) ; just a numeric argument, e.g. alloc 0
(defun* render-bytecode ((store generic-code-store)
@@ -1584,7 +1586,8 @@
(arity arity)
(address code-index))
"Set the code label `functor`/`arity` to point at `address`."
- (setf (wam-code-label wam functor arity) address))
+ (setf (wam-code-label wam functor arity)
+ address))
(defun* render-rules ((wam wam)
(functor symbol)
--- a/src/wam/constants.lisp Wed Jul 13 18:33:09 2016 +0000
+++ b/src/wam/constants.lisp Wed Jul 13 22:21:19 2016 +0000
@@ -77,8 +77,7 @@
:documentation "Maximum size of the WAM heap.")
(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.
+ ;; Functors are stored in a functor table.
:documentation "The maximum number of functors the WAM can keep track of.")
--- a/src/wam/dump.lisp Wed Jul 13 18:33:09 2016 +0000
+++ b/src/wam/dump.lisp Wed Jul 13 22:21:19 2016 +0000
@@ -11,10 +11,9 @@
"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)
+ ((:functor f) (destructuring-bind (functor . arity) f
(format nil "~A/~D " functor arity)))
- ((:constant c) (format nil "~A/0 " (wam-functor-symbol wam c)))
+ ((:constant c) (format nil "~A/0 " (car c)))
(t ""))))
@@ -22,7 +21,7 @@
;; todo flesh this out
(typecase value
(fixnum (format nil "~16,'0X" value))
- (t "~16{#<lisp object>~;~}")))
+ (t (format nil "~16<#<lisp object>~;~>"))))
(defun dump-heap (wam from to)
@@ -44,7 +43,7 @@
:do (progn
(print-cell address indent)
(cell-typecase (wam address)
- ((:functor f) (setf indent (wam-functor-arity wam f)))
+ ((:functor f) (setf indent (cdr f)))
(t (when (not (zerop indent))
(decf indent)))))))
(when (< to (wam-heap-pointer wam))
@@ -140,11 +139,9 @@
(format t " +----------+------------------+-------------------------------+~%"))
-(defun pretty-functor (functor-index functor-list)
- (when functor-list
- (destructuring-bind (symbol . arity)
- (elt functor-list functor-index)
- (format nil "~A/~D" symbol arity))))
+(defun pretty-functor (functor)
+ (destructuring-bind (symbol . arity) functor
+ (format nil "~A/~D" symbol arity)))
(defun pretty-argument (argument)
(typecase argument
@@ -155,115 +152,115 @@
(format nil "~10<~{ ~A~}~;~>" (mapcar #'pretty-argument arguments)))
-(defgeneric instruction-details (opcode arguments functor-list))
+(defgeneric instruction-details (opcode arguments))
-(defmethod instruction-details ((opcode t) arguments functor-list)
+(defmethod instruction-details ((opcode t) arguments)
(format nil "~A~A"
(opcode-short-name opcode)
(pretty-arguments arguments)))
-(defmethod instruction-details ((opcode (eql +opcode-get-structure+)) arguments functor-list)
+(defmethod instruction-details ((opcode (eql +opcode-get-structure+)) arguments)
(format nil "GETS~A ; X~A = ~A"
(pretty-arguments arguments)
(second arguments)
- (pretty-functor (first arguments) functor-list)))
+ (pretty-functor (first arguments))))
-(defmethod instruction-details ((opcode (eql +opcode-put-structure+)) arguments functor-list)
+(defmethod instruction-details ((opcode (eql +opcode-put-structure+)) arguments)
(format nil "PUTS~A ; X~A <- new ~A"
(pretty-arguments arguments)
(second arguments)
- (pretty-functor (first arguments) functor-list)))
+ (pretty-functor (first arguments))))
-(defmethod instruction-details ((opcode (eql +opcode-get-variable-local+)) arguments functor-list)
+(defmethod instruction-details ((opcode (eql +opcode-get-variable-local+)) arguments)
(format nil "GVAR~A ; X~A <- A~A"
(pretty-arguments arguments)
(first arguments)
(second arguments)))
-(defmethod instruction-details ((opcode (eql +opcode-get-variable-stack+)) arguments functor-list)
+(defmethod instruction-details ((opcode (eql +opcode-get-variable-stack+)) arguments)
(format nil "GVAR~A ; Y~A <- A~A"
(pretty-arguments arguments)
(first arguments)
(second arguments)))
-(defmethod instruction-details ((opcode (eql +opcode-get-value-local+)) arguments functor-list)
+(defmethod instruction-details ((opcode (eql +opcode-get-value-local+)) arguments)
(format nil "GVLU~A ; X~A = A~A"
(pretty-arguments arguments)
(first arguments)
(second arguments)))
-(defmethod instruction-details ((opcode (eql +opcode-get-value-stack+)) arguments functor-list)
+(defmethod instruction-details ((opcode (eql +opcode-get-value-stack+)) arguments)
(format nil "GVLU~A ; Y~A = A~A"
(pretty-arguments arguments)
(first arguments)
(second arguments)))
-(defmethod instruction-details ((opcode (eql +opcode-put-variable-local+)) arguments functor-list)
+(defmethod instruction-details ((opcode (eql +opcode-put-variable-local+)) arguments)
(format nil "PVAR~A ; X~A <- A~A <- new unbound REF"
(pretty-arguments arguments)
(first arguments)
(second arguments)))
-(defmethod instruction-details ((opcode (eql +opcode-put-variable-stack+)) arguments functor-list)
+(defmethod instruction-details ((opcode (eql +opcode-put-variable-stack+)) arguments)
(format nil "PVAR~A ; Y~A <- A~A <- new unbound REF"
(pretty-arguments arguments)
(first arguments)
(second arguments)))
-(defmethod instruction-details ((opcode (eql +opcode-put-value-local+)) arguments functor-list)
+(defmethod instruction-details ((opcode (eql +opcode-put-value-local+)) arguments)
(format nil "PVLU~A ; A~A <- X~A"
(pretty-arguments arguments)
(second arguments)
(first arguments)))
-(defmethod instruction-details ((opcode (eql +opcode-put-value-stack+)) arguments functor-list)
+(defmethod instruction-details ((opcode (eql +opcode-put-value-stack+)) arguments)
(format nil "PVLU~A ; A~A <- Y~A"
(pretty-arguments arguments)
(second arguments)
(first arguments)))
-(defmethod instruction-details ((opcode (eql +opcode-call+)) arguments functor-list)
+(defmethod instruction-details ((opcode (eql +opcode-call+)) arguments)
(format nil "CALL~A ; call ~A"
(pretty-arguments arguments)
(first arguments)))
-(defmethod instruction-details ((opcode (eql +opcode-jump+)) arguments functor-list)
+(defmethod instruction-details ((opcode (eql +opcode-jump+)) arguments)
(format nil "JUMP~A ; jump ~A"
(pretty-arguments arguments)
(first arguments)))
-(defmethod instruction-details ((opcode (eql +opcode-dynamic-call+)) arguments functor-list)
+(defmethod instruction-details ((opcode (eql +opcode-dynamic-call+)) arguments)
(format nil "DYCL~A ; dynamic call"
(pretty-arguments arguments)))
-(defmethod instruction-details ((opcode (eql +opcode-dynamic-jump+)) arguments functor-list)
+(defmethod instruction-details ((opcode (eql +opcode-dynamic-jump+)) arguments)
(format nil "DYJP~A ; dynamic jump"
(pretty-arguments arguments)))
-(defmethod instruction-details ((opcode (eql +opcode-get-constant+)) arguments functor-list)
+(defmethod instruction-details ((opcode (eql +opcode-get-constant+)) arguments)
(format nil "GCON~A ; X~A = CONSTANT ~A"
(pretty-arguments arguments)
(second arguments)
- (pretty-functor (first arguments) functor-list)))
+ (pretty-functor (first arguments))))
-(defmethod instruction-details ((opcode (eql +opcode-put-constant+)) arguments functor-list)
+(defmethod instruction-details ((opcode (eql +opcode-put-constant+)) arguments)
(format nil "PCON~A ; X~A <- CONSTANT ~A"
(pretty-arguments arguments)
(second arguments)
- (pretty-functor (first arguments) functor-list)))
+ (pretty-functor (first arguments))))
-(defmethod instruction-details ((opcode (eql +opcode-subterm-constant+)) arguments functor-list)
+(defmethod instruction-details ((opcode (eql +opcode-subterm-constant+)) arguments)
(format nil "SCON~A ; SUBTERM CONSTANT ~A"
(pretty-arguments arguments)
- (pretty-functor (first arguments) functor-list)))
+ (pretty-functor (first arguments))))
-(defmethod instruction-details ((opcode (eql +opcode-get-list+)) arguments functor-list)
+(defmethod instruction-details ((opcode (eql +opcode-get-list+)) arguments)
(format nil "GLST~A ; X~A = [vvv | vvv]"
(pretty-arguments arguments)
(first arguments)))
-(defmethod instruction-details ((opcode (eql +opcode-put-list+)) arguments functor-list)
+(defmethod instruction-details ((opcode (eql +opcode-put-list+)) arguments)
(format nil "PLST~A ; X~A = [vvv | vvv]"
(pretty-arguments arguments)
(first arguments)))
@@ -287,15 +284,14 @@
(let ((lbl (gethash addr lbls))) ; forgive me
(when lbl
(format t ";;;; BEGIN ~A~%"
- (pretty-functor lbl (wam-functors wam)))))
+ (pretty-functor lbl))))
(format t ";~A~4,'0X: "
(if (= (wam-program-counter wam) addr)
">>"
" ")
addr)
(format t "~A~%" (instruction-details (aref instruction 0)
- (rest (coerce instruction 'list))
- (wam-functors wam)))))
+ (rest (coerce instruction 'list))))))
(incf addr (length instruction))))))
(defun dump-code
@@ -335,12 +331,10 @@
(defun dump-labels (wam)
(format t "LABELS:~%~{ ~A -> ~4,'0X~^~%~}~%"
- (loop :for functor-index
+ (loop :for functor
:being :the :hash-keys :of (wam-code-labels wam)
:using (hash-value address)
- :nconc (list (pretty-functor functor-index
- (wam-functors wam))
- address))))
+ :nconc (list (pretty-functor functor) address))))
(defun dump-wam (wam from to)
--- a/src/wam/types.lisp Wed Jul 13 18:33:09 2016 +0000
+++ b/src/wam/types.lisp Wed Jul 13 22:21:19 2016 +0000
@@ -1,10 +1,13 @@
(in-package #:bones.wam)
+; (deftype cell-type () ; todo: pick one of these...
+; `(integer 0 ,(1- +number-of-cell-types+)))
+
(deftype cell-type ()
- `(integer 0 ,(1- +number-of-cell-types+)))
+ 'fixnum)
(deftype cell-value ()
- `(unsigned-byte 60)); soon...
+ '(or fixnum t))
(deftype type-store ()
@@ -29,15 +32,15 @@
(deftype register-index ()
`(integer 0 ,(1- +register-count+)))
-(deftype functor-index ()
- `(integer 0 ,(1- +functor-limit+)))
+(deftype fname ()
+ 'symbol)
(deftype arity ()
`(integer 0 ,+maximum-arity+))
(deftype functor ()
- '(cons symbol arity))
+ '(cons fname arity))
(deftype code-index ()
--- a/src/wam/vm.lisp Wed Jul 13 18:33:09 2016 +0000
+++ b/src/wam/vm.lisp Wed Jul 13 22:21:19 2016 +0000
@@ -34,28 +34,28 @@
"
(wam-heap-push! wam +cell-type-list+ (1+ (wam-heap-pointer wam))))
-(defun* push-new-functor! ((wam wam) (functor functor-index))
+(defun* push-new-functor! ((wam wam) (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))
+(defun* push-new-constant! ((wam wam) (constant functor))
(:returns heap-index)
"Push a new constant cell onto the heap, returning its address."
(wam-heap-push! wam +cell-type-constant+ constant))
-(defun* functors-match-p ((f1 functor-index)
- (f2 functor-index))
+(defun* functors-match-p ((f1 functor)
+ (f2 functor))
(:returns boolean)
"Return whether the two functor cell values represent the same functor."
- (= f1 f2))
+ (eq f1 f2))
-(defun* constants-match-p ((c1 functor-index)
- (c2 functor-index))
+(defun* constants-match-p ((c1 functor)
+ (c2 functor))
(:returns boolean)
"Return whether the two constant cells represent the same functor."
- (= c1 c2))
+ (eq c1 c2))
;;;; "Ancillary" Functions
@@ -222,7 +222,7 @@
(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)
+ (loop :with arity = (cdr f1)
:for i :from 1 :to arity :do
(wam-unification-stack-push! wam (+ s1 i))
(wam-unification-stack-push! wam (+ s2 i)))
@@ -324,7 +324,7 @@
;;;; Query Instructions
(define-instruction (%put-structure)
((wam wam)
- (functor functor-index)
+ (functor functor)
(register register-index))
(wam-set-local-register! wam register
+cell-type-structure+
@@ -358,7 +358,7 @@
;;;; Program Instructions
(define-instruction (%get-structure) ((wam wam)
- (functor functor-index)
+ (functor functor)
(register register-index))
(cell-typecase (wam (deref wam register) address)
;; If the register points at an unbound reference cell, we push two new
@@ -476,8 +476,7 @@
(functor functor)
(program-counter-increment instruction-size)
(is-tail boolean))
- (let* ((findex (wam-ensure-functor-index wam functor)) ; todo unfuck this once we finish splitting
- (target (wam-code-label wam findex)))
+ (let* ((target (wam-code-label wam functor)))
(if (not target)
;; Trying to call an unknown procedure.
(backtrack! wam)
@@ -486,7 +485,7 @@
(setf (wam-continuation-pointer wam) ; CP <- next instruction
(+ (wam-program-counter wam) program-counter-increment)))
(setf (wam-number-of-arguments wam) ; set NARGS
- (wam-functor-arity wam findex)
+ (cdr functor)
(wam-cut-pointer wam) ; set B0 in case we have a cut
(wam-backtrack-pointer wam)
@@ -512,18 +511,19 @@
;; 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.")))))
+ (load-arguments (cdr f) (1+ functor-address))
+ (%go f))))
+
+ ;; Zero-arity functors don't need to set up anything at all -- we can
+ ;; just call them immediately.
+ ((:constant c) (%go c))
+
+ ;; It's okay to do (call :var), but :var has to be bound by the time you
+ ;; actually reach it at runtime.
+ (:reference (error "Cannot dynamically call an unbound variable."))
+
+ ; You can't call/1 anything else.
+ (t (error "Cannot dynamically call something other than a structure.")))))
(define-instruction (%jump) ((wam wam) (functor functor))
@@ -645,7 +645,7 @@
(defun* %%match-constant
((wam wam)
- (constant functor-index)
+ (constant functor)
(address store-index))
(cell-typecase (wam (deref wam address) address)
(:reference
@@ -653,7 +653,7 @@
(trail! wam address))
((:constant c)
- (when (not (= constant c))
+ (when (not (eq constant c))
(backtrack! wam)))
(t (backtrack! wam))))
@@ -661,7 +661,7 @@
(define-instruction (%put-constant)
((wam wam)
- (constant functor-index)
+ (constant functor)
(register register-index))
(wam-set-local-register! wam register +cell-type-constant+ constant)
; todo we can probably elide this because constants never have subterms...
@@ -669,13 +669,13 @@
(define-instruction (%get-constant)
((wam wam)
- (constant functor-index)
+ (constant functor)
(register register-index))
(%%match-constant wam constant register))
(define-instruction (%subterm-constant)
((wam wam)
- (constant functor-index))
+ (constant functor))
(ecase (wam-mode wam)
(:read (%%match-constant wam constant (wam-subterm wam)))
(:write (push-new-constant! wam constant)))
@@ -722,10 +722,9 @@
((:reference r) (extract-var r))
((:structure s) (recur s))
((:list l) (cons (recur l) (recur (1+ l))))
- ((:constant c) (wam-functor-symbol wam c))
+ ((:constant c) (car c))
((:functor f)
- (destructuring-bind (functor . arity)
- (wam-functor-lookup wam f)
+ (destructuring-bind (functor . arity) f
(list* functor
(loop :repeat arity
:for subterm :from (+ address 1)
--- a/src/wam/wam.lisp Wed Jul 13 18:33:09 2016 +0000
+++ b/src/wam/wam.lisp Wed Jul 13 22:21:19 2016 +0000
@@ -130,8 +130,7 @@
;;; 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.
+;;; FUNCTOR cell values are a pointer to a `(fname . arity)` cons.
;;;
;;; CONSTANT cells are the same as functor cells, except that they always happen
;;; to refer to functors with an arity of zero.
@@ -193,8 +192,8 @@
(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-functor-value functor)
+ (define-unsafe %unsafe-constant-value functor)
(define-unsafe %unsafe-list-value store-index)
(define-unsafe %unsafe-stack-value stack-word))
@@ -721,17 +720,16 @@
:adjustable nil
:element-type 'code-word))
-(defun* wam-code-label ((wam wam)
- (functor functor-index))
+(defun* wam-code-label ((wam wam) (functor functor))
(:returns (or null code-index))
(gethash functor (wam-code-labels wam)))
(defun* (setf wam-code-label) ((new-value code-index)
(wam wam)
- (functor symbol)
+ (functor fname)
(arity arity))
;; Note that this takes a functor/arity and not a cons.
- (setf (gethash (wam-ensure-functor-index wam (cons functor arity))
+ (setf (gethash (wam-unique-functor wam (cons functor arity))
(wam-code-labels wam))
new-value))
@@ -830,7 +828,7 @@
"Cannot add clause ~S without an open logic stack frame."
clause)
(multiple-value-bind (functor arity) (find-predicate clause)
- (let ((label (wam-ensure-functor-index wam (cons functor arity))))
+ (let ((label (wam-unique-functor wam (cons functor arity))))
(assert-label-not-already-compiled wam clause label)
(with-slots (predicates)
(wam-current-logic-frame wam)
@@ -980,39 +978,19 @@
;;;; Functors
-;;; Functors are stored in an adjustable array. Cells refer to a functor using
-;;; the functor's address in this array.
+;;; Functors are stored in an adjustable array to uniquify them... for now.
-(declaim (inline wam-functor-lookup
- 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.
+(defun* wam-unique-functor ((wam wam) (functor functor))
+ (:returns functor)
+ "Return a unique version of the functor cons.
If the functor is not already in the table it will be added.
"
- (let ((functors (wam-functors wam)))
- (or (position functor functors :test #'equal)
- (vector-push-extend functor functors))))
-
-(defun* wam-functor-lookup ((wam wam) (functor-index functor-index))
- (:returns functor)
- "Return the functor with the given index in the WAM."
- (aref (wam-functors wam) functor-index))
-
-(defun* wam-functor-symbol ((wam wam) (functor-index functor-index))
- (:returns symbol)
- "Return the symbol of the functor with the given index in the WAM."
- (car (wam-functor-lookup wam functor-index)))
-
-(defun* wam-functor-arity ((wam wam) (functor-index functor-index))
- (:returns arity)
- "Return the arity of the functor with the given index in the WAM."
- (cdr (wam-functor-lookup wam functor-index)))
+ (or (find functor (wam-functors wam) :test #'equal)
+ (progn
+ (vector-push-extend functor (wam-functors wam))
+ functor)))
;;;; Unification Stack