--- a/src/wam.lisp Thu Mar 24 18:51:08 2016 +0000
+++ b/src/wam.lisp Thu Mar 24 23:08:43 2016 +0000
@@ -29,9 +29,11 @@
(define-constant +tag-reference+ #b10
:documentation "A pointer to a cell.")
-(define-constant +tag-symbol+ #b11
- :documentation "A constant symbol.")
+(define-constant +tag-functor+ #b11
+ :documentation "A functor.")
+(defparameter functor-arity-width 4)
+(defparameter functor-arity-bitmask #b1111)
(deftype heap-cell ()
`(unsigned-byte ,+cell-width+))
@@ -49,7 +51,7 @@
(defun* cell-value ((cell heap-cell))
(:returns heap-cell-value)
- (ash cell (- +cell-tag-bit-length+)))
+ (ash cell (- +cell-tag-width+)))
(defun* cell-type-name ((cell heap-cell))
@@ -58,7 +60,7 @@
(+tag-null+ "NULL")
(+tag-structure+ "STRUCTURE")
(+tag-reference+ "REFERENCE")
- (+tag-symbol+ "SYMBOL")))
+ (+tag-functor+ "FUNCTOR")))
(defun* cell-type-short-name ((cell heap-cell))
(:returns string)
@@ -66,12 +68,12 @@
(+tag-null+ "NUL")
(+tag-structure+ "STR")
(+tag-reference+ "REF")
- (+tag-symbol+ "SYM")))
+ (+tag-functor+ "FUN")))
(defun* make-cell ((tag heap-cell-tag) (value heap-cell-value))
(:returns heap-cell)
- (logior (ash value +cell-tag-bit-length+)
+ (logior (ash value +cell-tag-width+)
tag))
(defun* make-cell-null ()
@@ -86,36 +88,49 @@
(:returns heap-cell)
(make-cell +tag-reference+ value))
-(defun* make-cell-symbol ((value heap-cell-value))
+(defun* make-cell-functor ((functor symbol) (arity (integer 0)))
(:returns heap-cell)
- (make-cell +tag-symbol+ value))
+ (make-cell +tag-functor+ arity))
+
+
+; (defun cell-functor-name)
+(defun cell-functor-arity (cell)
+ (logand (cell-value cell)
+ functor-arity-bitmask))
;;;; Heap
(deftype heap-index ()
`(integer 0 ,array-total-size-limit))
-(defparameter *heap*
- (make-array 16
- :initial-element (make-cell-null)
- :element-type 'heap-cell))
+
+(defun heap-debug (addr cell)
+ (cond
+ ((= +tag-reference+ (cell-type cell))
+ (if (= addr (cell-value cell))
+ "unbound variable"
+ "variable pointer"))
+ ((= +tag-functor+ (cell-type cell))
+ (format nil "functor/~D" (cell-functor-arity cell)))
+ (t "")))
(defun dump-heap (heap from to highlight)
(format t "~%Dumping heap...~%")
(format t "Heap size: ~A~%~%" (length heap))
- (format t "+------+-----+--------------+~%")
- (format t "| ADDR | TYP | VALUE |~%")
- (format t "+------+-----+--------------+~%")
+ (format t "+------+-----+--------------+----------------------------+~%")
+ (format t "| ADDR | TYP | VALUE | DEBUG |~%")
+ (format t "+------+-----+--------------+----------------------------+~%")
(flet ((print-cell
(i cell)
- (format t "| ~4@A | ~A | ~12@A |~A~%"
+ (format t "| ~4@A | ~A | ~12@A | ~26A |~A~%"
i
(cell-type-short-name cell)
(cell-value cell)
+ (heap-debug i cell)
(if (= i highlight) " <===" ""))))
(loop :for i :from from :below to
:do (print-cell i (aref heap i))))
- (format t "+------+-----+--------------+~%")
+ (format t "+------+-----+--------------+----------------------------+~%")
(values))
(defun dump-heap-full (heap)
@@ -128,11 +143,27 @@
addr))
-(setf (aref *heap* 0) (make-cell-structure 12))
-(setf (aref *heap* 1) (make-cell-reference 42))
-(setf (aref *heap* 2) (make-cell-symbol 112))
+;;;; BEHOLD: THE WAM
+(defclass wam ()
+ ((heap
+ :initform (make-array 16
+ :initial-element (make-cell-null)
+ :element-type 'heap-cell)
+ :reader wam-heap
+ :documentation "The actual heap (stack).")
+ (heap-pointer
+ :initform 0
+ :accessor wam-heap-pointer
+ :documentation "The index of the first free cell on the heap (stack).")
+ (registers
+ :reader wam-registers
+ :initform (make-array 16
+ :initial-element (make-cell-null)
+ :element-type 'heap-cell)
+ :documentation "An array of the X_i registers.")))
-(dump-heap-full *heap*)
+(defun make-wam ()
+ (make-instance 'wam))
;;;; Terms
@@ -141,3 +172,159 @@
(h :z :w)
(f :w)))
+
+(defun variable-p (term)
+ (keywordp term))
+
+(defun parse-term (term)
+ "Parse a term into a series of register assignments."
+ (labels ((variable-p
+ (term)
+ (keywordp term))
+ (parse-variable
+ (var registers)
+ ;; If we've already seen this variable, just return it's position,
+ ;; otherwise allocate a register for it.
+ (or (position var registers)
+ (vector-push-extend var registers)))
+ (parse-structure
+ (structure registers)
+ (let* ((functor (first structure))
+ (arguments (rest structure))
+ (contents (list functor)))
+ (prog1
+ (vector-push-extend contents registers)
+ ;; Parse the arguments and splice the results into this cell
+ ;; once we're finished. The children should handle extending
+ ;; the registers as needed.
+ (nconc contents
+ (mapcar #'(lambda (arg)
+ (parse arg registers))
+ arguments)))))
+ (parse (term registers)
+ (if (variable-p term)
+ (parse-variable term registers)
+ (parse-structure term registers))))
+ (let ((registers (make-array 64 :fill-pointer 0 :adjustable t)))
+ (parse term registers)
+ (loop :for i :from 0
+ :for reg :across registers
+ :collect (cons i reg)))))
+
+(defun dump-parse (term)
+ (loop :for (i . reg) :in (parse-term term)
+ :do (format t "X~A -> ~S~%" i reg)))
+
+
+(defun flatten-register-assignments (registers)
+ "Flatten the set of register assignments into a minimal set."
+ (labels ((variable-assignment-p
+ (ass)
+ (keywordp (cdr ass)))
+ (assignment-less-p
+ (ass1 ass2)
+ (cond
+ ;; If 2 is a variable assignment, nothing can be less than it.
+ ((variable-assignment-p ass2) nil)
+
+ ;; If 2 isn't, but 1 is, then 1 < 2.
+ ((variable-assignment-p ass1) t)
+
+ ;; Otherwise they're both structure assignments.
+ ;; (N . foo A B C) (M . bar X Y Z)
+ ;;
+ ;; We need to make sure that if something inside 2 uses the
+ ;; target of 1, then 1 < 2.
+ ((member (car ass1) (cdr ass2)) t)
+
+ ;; Otherwise we don't care.
+ (t nil))))
+ (remove-if #'variable-assignment-p
+ (sort registers #'assignment-less-p))))
+
+
+(defun tokenize-assignments (assignments)
+ "Tokenize a flattened set of register assignments into a stream."
+ (mapcan #'(lambda (ass)
+ (destructuring-bind (register . (functor . arguments)) ass
+ ;; Take a single assignment like:
+ ;; X1 = f(a, b, c) (1 . (f a b c))
+ ;;
+ ;; And turn it into a stream of tokens:
+ ;; (X1 = f/3), a, b, c (1 f 3) a b c
+ (cons (list register functor (length arguments))
+ arguments)))
+ assignments))
+
+
+(defun* put-structure ((wam wam)
+ functor
+ (arity (integer 0))
+ (register (integer 0)))
+ (with-slots (heap registers heap-pointer) wam
+ (setf (aref heap heap-pointer)
+ (make-cell-structure (1+ heap-pointer)))
+ (setf (aref heap (1+ heap-pointer))
+ (make-cell-functor functor arity))
+ (setf (aref registers register)
+ (aref heap heap-pointer))
+ (incf heap-pointer 2)))
+
+(defun* set-variable ((wam wam) (register (integer 0)))
+ (with-slots (heap registers heap-pointer) wam
+ ;; This cell will reference itself (i.e. it's an unbound variable).
+ (setf (aref heap heap-pointer)
+ (make-cell-reference heap-pointer))
+ ;; Set the register to match the cell we just made.
+ (setf (aref registers register)
+ (aref heap heap-pointer))
+ ;; Bump the heap pointer.
+ (incf heap-pointer)))
+
+(defun* set-value ((wam wam) (register (integer 0)))
+ (with-slots (heap registers heap-pointer) wam
+ (setf (aref heap heap-pointer)
+ (aref registers register))
+ (incf heap-pointer)))
+
+
+(defun generate-actions (tokens)
+ "Generate a series of 'machine instructions' from a stream of tokens."
+ (let ((seen (list)))
+ (flet ((handle-structure
+ (register functor arity)
+ (push register seen)
+ (list #'put-structure functor arity register))
+ (handle-register
+ (register)
+ (if (member register seen)
+ (list #'set-value register)
+ (progn
+ (push register seen)
+ (list #'set-variable register)))))
+ (loop :for token :in tokens
+ :collect (if (consp token)
+ (apply #'handle-structure token)
+ (handle-register token))))))
+
+
+(defun build-heap (wam actions)
+ (mapc #'(lambda (action)
+ (apply (car action) wam (cdr action)))
+ actions)
+ (values))
+
+
+; (defparameter *wam* (make-wam))
+
+; (dump-heap-full (wam-heap *wam*))
+
+; (build-heap
+; *wam*
+; (generate-actions
+; (tokenize-assignments
+; (flatten-register-assignments
+; (parse-term p)))))
+
+; (dump-heap-full (wam-heap *wam*))
+