# HG changeset patch # User Steve Losh # Date 1458845468 0 # Node ID f57121ef42291a1fbc5a07707338fe33dea44bf4 # Parent 06dedca0fd866bf01ad2d013f5b135da42b90de7 Implement a rudimentary heap for the WAM, part 0 diff -r 06dedca0fd86 -r f57121ef4229 bones.asd --- a/bones.asd Thu Mar 24 15:26:03 2016 +0000 +++ b/bones.asd Thu Mar 24 18:51:08 2016 +0000 @@ -19,6 +19,7 @@ (:file "package") (:module "src" :components ((:file "paip") + (:file "wam") ; (:file "paip-compiled") (:file "bones"))))) diff -r 06dedca0fd86 -r f57121ef4229 package.lisp --- a/package.lisp Thu Mar 24 15:26:03 2016 +0000 +++ b/package.lisp Thu Mar 24 18:51:08 2016 +0000 @@ -2,6 +2,10 @@ (:use #:cl) (:export #:hello)) +(defpackage #:bones.wam + (:use #:cl #:defstar #:bones.utils #:optima) + (:import-from #:optima #:match)) + (defpackage #:bones.paip (:use #:cl #:defstar #:bones.utils) (:documentation "Test?") diff -r 06dedca0fd86 -r f57121ef4229 src/make-utilities.lisp --- a/src/make-utilities.lisp Thu Mar 24 15:26:03 2016 +0000 +++ b/src/make-utilities.lisp Thu Mar 24 18:51:08 2016 +0000 @@ -3,5 +3,6 @@ (qtlc:save-utils-as "utils.lisp" :utilities '(:define-constant :set-equal - :curry) + :curry + :switch) :package "BONES.UTILS") diff -r 06dedca0fd86 -r f57121ef4229 src/utils.lisp --- a/src/utils.lisp Thu Mar 24 15:26:03 2016 +0000 +++ b/src/utils.lisp Thu Mar 24 18:51:08 2016 +0000 @@ -2,7 +2,7 @@ ;;;; See http://quickutil.org for details. ;;;; To regenerate: -;;;; (qtlc:save-utils-as "utils.lisp" :utilities '(:DEFINE-CONSTANT :SET-EQUAL :CURRY) :ensure-package T :package "BONES.UTILS") +;;;; (qtlc:save-utils-as "utils.lisp" :utilities '(:DEFINE-CONSTANT :SET-EQUAL :CURRY :SWITCH) :ensure-package T :package "BONES.UTILS") (eval-when (:compile-toplevel :load-toplevel :execute) (unless (find-package "BONES.UTILS") @@ -15,7 +15,9 @@ (when (boundp '*utilities*) (setf *utilities* (union *utilities* '(:DEFINE-CONSTANT :SET-EQUAL :MAKE-GENSYM-LIST :ENSURE-FUNCTION - :CURRY)))) + :CURRY :STRING-DESIGNATOR + :WITH-GENSYMS :EXTRACT-FUNCTION-NAME + :SWITCH)))) (defun %reevaluate-constant (name value test) (if (not (boundp name)) @@ -109,7 +111,101 @@ (lambda (&rest more) (apply ,fun ,@curries more))))) + + (deftype string-designator () + "A string designator type. A string designator is either a string, a symbol, +or a character." + `(or symbol string character)) + (eval-when (:compile-toplevel :load-toplevel :execute) - (export '(define-constant set-equal curry))) + (defmacro with-gensyms (names &body forms) + "Binds each variable named by a symbol in `names` to a unique symbol around +`forms`. Each of `names` must either be either a symbol, or of the form: + + (symbol string-designator) + +Bare symbols appearing in `names` are equivalent to: + + (symbol symbol) + +The string-designator is used as the argument to `gensym` when constructing the +unique symbol the named variable will be bound to." + `(let ,(mapcar (lambda (name) + (multiple-value-bind (symbol string) + (etypecase name + (symbol + (values name (symbol-name name))) + ((cons symbol (cons string-designator null)) + (values (first name) (string (second name))))) + `(,symbol (gensym ,string)))) + names) + ,@forms)) + + (defmacro with-unique-names (names &body forms) + "Binds each variable named by a symbol in `names` to a unique symbol around +`forms`. Each of `names` must either be either a symbol, or of the form: + + (symbol string-designator) + +Bare symbols appearing in `names` are equivalent to: + + (symbol symbol) + +The string-designator is used as the argument to `gensym` when constructing the +unique symbol the named variable will be bound to." + `(with-gensyms ,names ,@forms)) + ) ; eval-when +(eval-when (:compile-toplevel :load-toplevel :execute) + (defun extract-function-name (spec) + "Useful for macros that want to mimic the functional interface for functions +like `#'eq` and `'eq`." + (if (and (consp spec) + (member (first spec) '(quote function))) + (second spec) + spec)) + ) ; eval-when + + (eval-when (:compile-toplevel :load-toplevel :execute) + (defun generate-switch-body (whole object clauses test key &optional default) + (with-gensyms (value) + (setf test (extract-function-name test)) + (setf key (extract-function-name key)) + (when (and (consp default) + (member (first default) '(error cerror))) + (setf default `(,@default "No keys match in SWITCH. Testing against ~S with ~S." + ,value ',test))) + `(let ((,value (,key ,object))) + (cond ,@(mapcar (lambda (clause) + (if (member (first clause) '(t otherwise)) + (progn + (when default + (error "Multiple default clauses or illegal use of a default clause in ~S." + whole)) + (setf default `(progn ,@(rest clause))) + '(())) + (destructuring-bind (key-form &body forms) clause + `((,test ,value ,key-form) + ,@forms)))) + clauses) + (t ,default)))))) + + (defmacro switch (&whole whole (object &key (test 'eql) (key 'identity)) + &body clauses) + "Evaluates first matching clause, returning its values, or evaluates and +returns the values of `default` if no keys match." + (generate-switch-body whole object clauses test key)) + + (defmacro eswitch (&whole whole (object &key (test 'eql) (key 'identity)) + &body clauses) + "Like `switch`, but signals an error if no key matches." + (generate-switch-body whole object clauses test key '(error))) + + (defmacro cswitch (&whole whole (object &key (test 'eql) (key 'identity)) + &body clauses) + "Like `switch`, but signals a continuable error if no key matches." + (generate-switch-body whole object clauses test key '(cerror "Return NIL from CSWITCH."))) + +(eval-when (:compile-toplevel :load-toplevel :execute) + (export '(define-constant set-equal curry switch eswitch cswitch))) ;;;; END OF utils.lisp ;;;; diff -r 06dedca0fd86 -r f57121ef4229 src/wam.lisp --- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/src/wam.lisp Thu Mar 24 18:51:08 2016 +0000 @@ -0,0 +1,143 @@ +(in-package #:bones.wam) + +(declaim (optimize (safety 3) (debug 3))) + +;;;; Utilities +(defun pb (b) + (format t "~B~%" b)) + + +;;;; Heap Cells +(define-constant +cell-width+ 16 + :documentation "Number of bits in each heap cell.") + +(define-constant +cell-tag-width+ 2 + :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+ (1- (ash 1 +cell-tag-width+)) + :documentation "Bitmask for masking the cell type tags.") + +(define-constant +tag-null+ #b00 + :documentation "An empty cell.") + +(define-constant +tag-structure+ #b01 + :documentation "A structure cell.") + +(define-constant +tag-reference+ #b10 + :documentation "A pointer to a cell.") + +(define-constant +tag-symbol+ #b11 + :documentation "A constant symbol.") + + +(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+)) + + +(defun* cell-type ((cell heap-cell)) + (:returns heap-cell-tag) + (logand cell +cell-tag-bitmask+)) + +(defun* cell-value ((cell heap-cell)) + (:returns heap-cell-value) + (ash cell (- +cell-tag-bit-length+))) + + +(defun* cell-type-name ((cell heap-cell)) + (:returns string) + (eswitch ((cell-type cell) :test #'=) + (+tag-null+ "NULL") + (+tag-structure+ "STRUCTURE") + (+tag-reference+ "REFERENCE") + (+tag-symbol+ "SYMBOL"))) + +(defun* cell-type-short-name ((cell heap-cell)) + (:returns string) + (eswitch ((cell-type cell) :test #'=) + (+tag-null+ "NUL") + (+tag-structure+ "STR") + (+tag-reference+ "REF") + (+tag-symbol+ "SYM"))) + + +(defun* make-cell ((tag heap-cell-tag) (value heap-cell-value)) + (:returns heap-cell) + (logior (ash value +cell-tag-bit-length+) + tag)) + +(defun* make-cell-null () + (:returns heap-cell) + (make-cell +tag-null+ 0)) + +(defun* make-cell-structure ((value heap-cell-value)) + (:returns heap-cell) + (make-cell +tag-structure+ value)) + +(defun* make-cell-reference ((value heap-cell-value)) + (:returns heap-cell) + (make-cell +tag-reference+ value)) + +(defun* make-cell-symbol ((value heap-cell-value)) + (:returns heap-cell) + (make-cell +tag-symbol+ value)) + + +;;;; 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 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 "+------+-----+--------------+~%") + (flet ((print-cell + (i cell) + (format t "| ~4@A | ~A | ~12@A |~A~%" + i + (cell-type-short-name cell) + (cell-value cell) + (if (= i highlight) " <===" "")))) + (loop :for i :from from :below to + :do (print-cell i (aref heap i)))) + (format t "+------+-----+--------------+~%") + (values)) + +(defun dump-heap-full (heap) + (dump-heap heap 0 (length heap) -1)) + +(defun dump-heap-around (heap addr width) + (dump-heap heap + (max 0 (- addr width)) + (min (length heap) (+ addr width 1)) + 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)) + +(dump-heap-full *heap*) + + +;;;; Terms +(defparameter p + '(p :z + (h :z :w) + (f :w))) +