--- a/bones.asd Wed Mar 30 00:30:33 2016 +0000
+++ b/bones.asd Wed Mar 30 13:44:34 2016 +0000
@@ -22,11 +22,13 @@
:components ((:file "paip")
(:module "wam"
:components ((:file "constants")
+ (:file "types")
(:file "topological-sort")
(:file "cells")
+ (:file "opcodes")
(:file "wam")
(:file "instructions")
- (:file "dump")
- (:file "compile")))
+ (:file "compile")
+ (:file "dump")))
(:file "bones")))))
--- a/src/wam/constants.lisp Wed Mar 30 00:30:33 2016 +0000
+++ b/src/wam/constants.lisp Wed Mar 30 13:44:34 2016 +0000
@@ -13,11 +13,16 @@
:documentation "Bitmask for masking the cell type tags.")
-(define-constant +addressable-values+ (expt 2 +cell-value-width+)
- :documentation "Number of addressable values, based on cell width.")
+(define-constant +heap-limit+ (expt 2 +cell-value-width+)
+ ;; We can only address 2^value-bits cells.
+ :documentation "Maximum size of the WAM heap.")
+
-(define-constant +heap-limit+ +addressable-values+
- :documentation "Maximum size of the WAM heap.")
+(define-constant +code-word-size+ 16
+ :documentation "Size (in bits) of each word in the code store.")
+
+(define-constant +code-limit+ (expt 2 +code-word-size+)
+ :documentation "Maximum size of the WAM code store.")
(define-constant +tag-null+ #b00
@@ -46,3 +51,8 @@
(define-constant +maximum-arity+ (1- (expt 2 +functor-arity-width+))
:documentation "The maximum allowed arity of functors.")
+
+(define-constant +opcode-get-structure+ 1)
+(define-constant +opcode-unify-variable+ 2)
+(define-constant +opcode-unify-value+ 3)
+
--- a/src/wam/dump.lisp Wed Mar 30 00:30:33 2016 +0000
+++ b/src/wam/dump.lisp Wed Mar 30 13:44:34 2016 +0000
@@ -21,10 +21,10 @@
(t ""))
(registers-pointing-to wam addr)))
-
(defun dump-heap (wam from to highlight)
;; This code is awful, sorry.
(let ((heap (wam-heap wam)))
+ (format t "HEAP~%")
(format t " +------+-----+--------------+--------------------------------------+~%")
(format t " | ADDR | TYP | VALUE | DEBUG |~%")
(format t " +------+-----+--------------+--------------------------------------+~%")
@@ -47,6 +47,22 @@
(values)))
+(defun instruction-aesthetic (instruction)
+ (format nil "~A~{ ~4,'0X~}"
+ (opcode-short-name (aref instruction 0))
+ (rest (coerce instruction 'list))))
+
+(defun dump-code (wam)
+ (let ((code (wam-code wam)))
+ (format t "CODE~%")
+ (let ((addr 0))
+ (while (< addr (length code))
+ (format t "; ~4,'0X: " addr)
+ (let ((instruction (wam-code-instruction wam addr)))
+ (format t "~A~%" (instruction-aesthetic instruction))
+ (incf addr (length instruction)))))))
+
+
(defun dump-wam-registers (wam)
(format t "REGISTERS:~%")
(format t "~5@A ->~6@A~%" "S" (wam-s wam))
@@ -70,9 +86,12 @@
(format t " MODE: ~A~%" (wam-mode wam))
(dump-wam-functors wam)
(format t "HEAP SIZE: ~A~%" (length (wam-heap wam)))
+ (format t "PROGRAM C: ~A~%" (wam-program-counter wam))
(dump-wam-registers wam)
(format t "~%")
- (dump-heap wam from to highlight))
+ (dump-heap wam from to highlight)
+ (format t "~%")
+ (dump-code wam))
(defun dump-wam-full (wam)
(dump-wam wam 0 (length (wam-heap wam)) -1))
--- /dev/null Thu Jan 01 00:00:00 1970 +0000
+++ b/src/wam/opcodes.lisp Wed Mar 30 13:44:34 2016 +0000
@@ -0,0 +1,32 @@
+(in-package #:bones.wam)
+
+;;; This file contains some basic helpers for working with opcodes themselves.
+;;; For the actual implementation of the instructions, see instructions.lisp.
+
+
+(defun* instruction-size ((opcode opcode))
+ (:returns (integer 0 4))
+ "Return the size of an instruction for the given opcode.
+
+ The size includes one word for the opcode itself and one for each argument.
+
+ "
+ (eswitch (opcode)
+ (+opcode-get-structure+ 4)
+ (+opcode-unify-variable+ 2)
+ (+opcode-unify-value+ 2)))
+
+
+(defun* opcode-name ((opcode opcode))
+ (:returns string)
+ (eswitch (opcode)
+ (+opcode-get-structure+ "GET-STRUCTURE")
+ (+opcode-unify-variable+ "UNIFY-VARIABLE")
+ (+opcode-unify-value+ "UNIFY-VALUE")))
+
+(defun* opcode-short-name ((opcode opcode))
+ (:returns string)
+ (eswitch (opcode)
+ (+opcode-get-structure+ "GETS")
+ (+opcode-unify-variable+ "UVAR")
+ (+opcode-unify-value+ "UVLU")))
--- /dev/null Thu Jan 01 00:00:00 1970 +0000
+++ b/src/wam/types.lisp Wed Mar 30 13:44:34 2016 +0000
@@ -0,0 +1,34 @@
+(in-package #:bones.wam)
+
+(deftype heap-cell ()
+ `(unsigned-byte ,+cell-width+))
+
+(deftype heap-cell-tag ()
+ `(unsigned-byte ,+cell-tag-width+))
+
+(deftype heap-cell-value ()
+ `(unsigned-byte ,+cell-value-width+))
+
+
+(deftype heap-index ()
+ `(integer 0 ,(1- +heap-limit+)))
+
+(deftype register-index ()
+ `(integer 0 ,(1- +register-count+)))
+
+(deftype functor-index ()
+ `(integer 0 ,(1- array-total-size-limit)))
+
+
+(deftype arity ()
+ `(integer 0 ,+maximum-arity+))
+
+
+(deftype code-word ()
+ `(unsigned-byte ,+code-word-size+))
+
+(deftype code-index ()
+ `(integer 0 ,(1- +code-limit+)))
+
+(deftype opcode ()
+ '(integer 0 3))
--- a/src/wam/wam.lisp Wed Mar 30 00:30:33 2016 +0000
+++ b/src/wam/wam.lisp Wed Mar 30 13:44:34 2016 +0000
@@ -5,10 +5,19 @@
((heap
:initform (make-array 1024
:fill-pointer 0
+ :adjustable t
:initial-element (make-cell-null)
:element-type 'heap-cell)
:reader wam-heap
:documentation "The actual heap (stack).")
+ (code
+ :initform (make-array 1024
+ :fill-pointer 0
+ :adjustable t
+ :initial-element 0
+ :element-type 'code-word)
+ :reader wam-code
+ :documentation "The code store.")
(functors
:initform (make-array 16
:fill-pointer 0
@@ -41,6 +50,11 @@
:initform nil
:type (or null heap-index)
:documentation "The S register (address of next subterm to match).")
+ (program-counter
+ :accessor wam-program-counter
+ :initform 0
+ :type 'code-index
+ :documentation "The Program Counter for the WAM code store.")
(mode
:accessor wam-mode
:initform nil
@@ -53,10 +67,6 @@
;;;; Heap
-;;; The WAM heap is a fixed-length array of cells and a heap pointer.
-;;;
-;;; TODO: Consider using an adjustable array. There must still be a max size
-;;; because you can only index so many addresses with N bits.
(defun* wam-heap-push! ((wam wam) (cell heap-cell))
(:returns (values heap-cell heap-index))
"Push the cell onto the WAM heap and increment the heap pointer.
@@ -84,6 +94,55 @@
(setf (aref (wam-heap wam) address) new-value))
+;;;; Code
+(defun* wam-code-word ((wam wam) (address code-index))
+ (:returns code-word)
+ "Return the word at the given address in the code store."
+ (aref (wam-code wam) address))
+
+(defun (setf wam-code-word) (word wam address)
+ (setf (aref (wam-code wam) address) word))
+
+
+(defun* wam-code-instruction ((wam wam) (address code-index))
+ "Return the full instruction at the given address in the code store."
+ (make-array (instruction-size (wam-code-word wam address))
+ :displaced-to (wam-code wam)
+ :displaced-index-offset address
+ :adjustable nil
+ :element-type 'code-word))
+
+
+(defun* wam-code-push-word! ((wam wam) (word code-word))
+ "Push the given word into the code store and return its new address."
+ (:returns code-index)
+ (with-slots (code) wam
+ (if (= +code-limit+ (fill-pointer code))
+ (error "WAM code store exhausted.")
+ (vector-push-extend word code))))
+
+(defun* wam-code-push! ((wam wam) (opcode opcode) &rest (arguments code-word))
+ "Push the given instruction into the code store and return its new address.
+
+ The address will be the address of the start of the instruction (i.e. the
+ address of the opcode).
+
+ "
+ (:returns code-index)
+ (assert (= (length arguments)
+ (1- (instruction-size opcode)))
+ (arguments)
+ "Cannot push opcode ~A with ~D arguments ~S, it requires exactly ~D."
+ (opcode-name opcode)
+ (length arguments)
+ arguments
+ (instruction-size opcode))
+ (prog1
+ (wam-code-push-word! wam opcode)
+ (dolist (arg arguments)
+ (wam-code-push-word! wam arg))))
+
+
;;;; Registers
;;; WAM registers are implemented as an array of a fixed number of registers.
;;; A register contains the address of a cell in the heap.