# HG changeset patch # User Steve Losh # Date 1459868428 0 # Node ID 6138ec555cde8d151e58955640d01bd04d589d49 # Parent 6dc3f4e034548c41515d04b22fbe187d6e766f53 Change functor representation Functors are now (symbol . arity) pairs in the functor table, and the functor cells simply contain the address into the table and nothing more. diff -r 6dc3f4e03454 -r 6138ec555cde src/wam/cells.lisp --- a/src/wam/cells.lisp Fri Apr 01 19:16:23 2016 +0000 +++ b/src/wam/cells.lisp Tue Apr 05 15:00:28 2016 +0000 @@ -55,14 +55,7 @@ (defun* cell-functor-index ((cell heap-cell)) (:returns functor-index) - (ash (cell-value cell) - (- +functor-arity-width+))) - -(defun* cell-functor-arity ((cell heap-cell)) - (:returns arity) - (values - (logand (cell-value cell) - +functor-arity-bitmask+))) + (cell-value cell)) (defun* cell-aesthetic ((cell heap-cell)) @@ -74,9 +67,8 @@ (+tag-structure+ (format nil " ~D" (cell-value cell))) (+tag-functor+ - (format nil " functor ~D/~D" - (cell-functor-index cell) - (cell-functor-arity cell))) + (format nil " functor ~D" + (cell-functor-index cell))) (+tag-reference+ (format nil " ~D" (cell-value cell)))))) @@ -116,12 +108,8 @@ (:returns heap-cell) (make-cell +tag-reference+ value)) -(defun* make-cell-functor ((functor-index functor-index) - (arity arity)) +(defun* make-cell-functor ((functor-index functor-index)) (:returns heap-cell) - (make-cell - +tag-functor+ - (logior (ash functor-index +functor-arity-width+) - arity))) + (make-cell +tag-functor+ functor-index)) diff -r 6dc3f4e03454 -r 6138ec555cde src/wam/compile.lisp --- a/src/wam/compile.lisp Fri Apr 01 19:16:23 2016 +0000 +++ b/src/wam/compile.lisp Tue Apr 05 15:00:28 2016 +0000 @@ -296,7 +296,7 @@ ;;; (#'%set-value 1) ;;; (#'%set-value 2) -(defun generate-actions (tokens store mode) +(defun generate-actions (wam tokens store mode) "Generate a series of machine instructions from a stream of tokens." (let ((seen (list))) (flet ((handle-argument (register target) @@ -319,7 +319,9 @@ (:program +opcode-get-structure+) (:query +opcode-put-structure+)) store) - (vector-push-extend arity store) ; todo: add functor + (vector-push-extend + (wam-ensure-functor-index wam (cons functor arity)) + store) (vector-push-extend register store)) (handle-register (register) (if (member register seen) @@ -344,23 +346,29 @@ (handle-structure register functor arity)) (register (handle-register register))))))) -(defun generate-query-actions (tokens store) - (generate-actions tokens store :query)) +(defun generate-query-actions (wam tokens store) + (generate-actions wam tokens store :query)) -(defun generate-program-actions (tokens store) - (generate-actions tokens store :program)) +(defun generate-program-actions (wam tokens store) + (generate-actions wam tokens store :program)) ;;;; UI -(defun compile-query-term (term) +(defun compile-query-term (wam term) "Parse a Lisp query term into a series of WAM machine instructions." - (-> term + (let ((code (make-array 64 + :fill-pointer 0 + :adjustable t + :element-type 'code-word))) + (-<>> term parse-term - flatten-query - tokenize-assignments - generate-query-actions)) + (multiple-value-call #'inline-structure-argument-assignments) + (multiple-value-call #'flatten-query) + (multiple-value-call #'tokenize-assignments) + (generate-query-actions wam <> code)) + code)) -(defun compile-program-term (term) +(defun compile-program-term (wam term) "Parse a Lisp program term into a series of WAM machine instructions." (-> term parse-term diff -r 6dc3f4e03454 -r 6138ec555cde src/wam/dump.lisp --- a/src/wam/dump.lisp Fri Apr 01 19:16:23 2016 +0000 +++ b/src/wam/dump.lisp Tue Apr 05 15:00:28 2016 +0000 @@ -47,17 +47,52 @@ (values))) -(defun instruction-aesthetic (instruction) - (format nil "~A~{ ~4,'0X~}" - (opcode-short-name (aref instruction 0)) - (rest (coerce instruction 'list)))) +(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-arguments (arguments) + (format nil "~{ ~4,'0X~}" arguments)) + +(defgeneric instruction-details (opcode arguments functor-list)) + +(defmethod instruction-details ((opcode t) arguments functor-list) + (format nil "~A~A" + (opcode-short-name opcode) + (pretty-arguments arguments))) -(defun dump-code-store (code-store &optional (from 0) (to (length code-store))) +(defmethod instruction-details ((opcode (eql +opcode-get-structure+)) arguments functor-list) + (format nil "GETS~A ; ~A" + (pretty-arguments arguments) + (pretty-functor (first arguments) functor-list))) + +(defmethod instruction-details ((opcode (eql +opcode-put-structure+)) arguments functor-list) + (format nil "PUTS~A ; ~A" + (pretty-arguments arguments) + (pretty-functor (first arguments) functor-list))) + + +; (defmethod instruction-details ((opcode (eql +opcode-set-variable+)) arguments functor-list)) +; (defmethod instruction-details ((opcode (eql +opcode-set-value+)) arguments functor-list)) +; (defmethod instruction-details ((opcode (eql +opcode-put-variable+)) arguments functor-list)) +; (defmethod instruction-details ((opcode (eql +opcode-put-value+)) arguments functor-list)) + +; (defmethod instruction-details ((opcode (eql +opcode-call+)) arguments functor-list)) +; (defmethod instruction-details ((opcode (eql +opcode-proceed+)) arguments functor-list)) + +(defun dump-code-store (code-store &optional + (from 0) + (to (length code-store)) + functor-list) (let ((addr from)) (while (< addr to) (format t "; ~4,'0X: " addr) (let ((instruction (retrieve-instruction code-store addr))) - (format t "~A~%" (instruction-aesthetic instruction)) + (format t "~A~%" (instruction-details (aref instruction 0) + (rest (coerce instruction 'list)) + functor-list)) (incf addr (length instruction)))))) (defun dump-code (wam &optional (from 0) (to (length (wam-code wam)))) diff -r 6dc3f4e03454 -r 6138ec555cde src/wam/types.lisp --- a/src/wam/types.lisp Fri Apr 01 19:16:23 2016 +0000 +++ b/src/wam/types.lisp Tue Apr 05 15:00:28 2016 +0000 @@ -23,6 +23,9 @@ (deftype arity () `(integer 0 ,+maximum-arity+)) +(deftype functor () + '(cons symbol arity)) + (deftype code-word () `(unsigned-byte ,+code-word-size+)) diff -r 6dc3f4e03454 -r 6138ec555cde src/wam/wam.lisp --- a/src/wam/wam.lisp Fri Apr 01 19:16:23 2016 +0000 +++ b/src/wam/wam.lisp Tue Apr 05 15:00:28 2016 +0000 @@ -19,12 +19,12 @@ :reader wam-code :documentation "The code store.") (functors - :initform (make-array 16 + :initform (make-array 64 :fill-pointer 0 :adjustable t - :element-type 'symbol) + :element-type 'functors) :accessor wam-functors - :documentation "The array of functor symbols in this WAM.") + :documentation "The array of functors in this WAM.") (registers :reader wam-registers :initform (make-array +register-count+ @@ -180,13 +180,10 @@ ;;;; Functors -;;; Functors are symbols stored in an adjustable array. Cells refer to -;;; a functor using the functor's address in this array. -;;; -;;; TODO: Limit the number of functors based on the number of addressable -;;; functors in the functor cell index bits. +;;; Functors are stored in an adjustable array. Cells refer to a functor using +;;; the functor's address in this array. -(defun* wam-ensure-functor-index ((wam wam) (functor symbol)) +(defun* wam-ensure-functor-index ((wam wam) (functor functor)) (:returns functor-index) "Return the index of the functor in the WAM's functor table. @@ -194,7 +191,7 @@ " (with-slots (functors) wam - (or (position functor functors) + (or (position functor functors :test #'equal) (vector-push-extend functor functors)))) (defun* wam-functor-lookup ((wam wam) (functor-index functor-index))