# HG changeset patch # User Steve Losh # Date 1468613786 0 # Node ID e555488c15e69fd384c5a99e7b15bfb68ccba3f5 # Parent a095d20eeebc620e2a9d1e8b380c75d047dd2ede De-CLOS the parse tree diff -r a095d20eeebc -r e555488c15e6 .lispwords --- a/.lispwords Fri Jul 15 19:37:17 2016 +0000 +++ b/.lispwords Fri Jul 15 20:16:26 2016 +0000 @@ -2,7 +2,6 @@ (1 repeat) (2 define-instruction define-instructions) (1 with-database) -(2 set-when-unbound) (1 recursively) (1 when-let) (1 rule) diff -r a095d20eeebc -r e555488c15e6 src/wam/compiler/1-parsing.lisp --- a/src/wam/compiler/1-parsing.lisp Fri Jul 15 19:37:17 2016 +0000 +++ b/src/wam/compiler/1-parsing.lisp Fri Jul 15 20:16:26 2016 +0000 @@ -7,86 +7,45 @@ ;;;; ,| ;;;; `' -(defclass node () ()) +; todo functor -> fname + +(defstruct node) + -(defclass top-level-node (node) - ((functor :accessor node-functor - :type symbol - :initarg :functor) - (arity :accessor node-arity - :type arity - :initarg :arity) - (arguments :accessor node-arguments - :type list - :initarg :arguments))) +(defstruct (top-level-node (:include node)) + (functor nil :type symbol) + (arity 0 :type arity) + (arguments nil :type list)) -(defclass vanilla-node (node) - ((register :accessor node-register - :type register - :documentation "The register allocated to store this node."))) +(defstruct (vanilla-node (:include node) + (:conc-name node-)) + ;; The register allocated to store this node. + (register nil :type (or null register))) -(defclass structure-node (vanilla-node) - ((functor :accessor node-functor - :type symbol - :initarg :functor) - (arity :accessor node-arity - :type arity - :initarg :arity) - (arguments :accessor node-arguments - :type list - :initarg :arguments))) +(defstruct (structure-node (:include vanilla-node) + (:conc-name node-)) + (functor nil :type symbol) + (arity 0 :type arity) + (arguments nil :type list)) -(defclass variable-node (vanilla-node) - ((variable :accessor node-variable - :type symbol - :initarg :variable))) - -(defclass argument-variable-node (variable-node) - ((secondary-register - :accessor node-secondary-register - :type register - :documentation - "The register that actually holds the variable (NOT the argument register)."))) - -(defclass list-node (vanilla-node) - ((head :accessor node-head :type node :initarg :head) - (tail :accessor node-tail :type node :initarg :tail))) - -(defclass lisp-object-node (vanilla-node) - ((object :accessor node-object :type t :initarg :object))) - +(defstruct (variable-node (:include vanilla-node) + (:conc-name node-)) + (variable nil :type symbol)) -; todo functor -> fname -(defun* make-top-level-node ((functor symbol) (arity arity) (arguments list)) - (:returns top-level-node) - (values (make-instance 'top-level-node - :functor functor - :arity arity - :arguments arguments))) - -(defun* make-structure-node ((functor symbol) (arity arity) (arguments list)) - (:returns structure-node) - (values (make-instance 'structure-node - :functor functor - :arity arity - :arguments arguments))) +(defstruct (argument-variable-node (:include variable-node) + (:conc-name node-)) + ;; The register that actually holds the variable (NOT the argument register). + (secondary-register nil :type (or null register))) -(defun* make-variable-node ((variable symbol)) - (:returns variable-node) - (values (make-instance 'variable-node :variable variable))) - -(defun* make-argument-variable-node ((variable symbol)) - (:returns variable-node) - (values (make-instance 'argument-variable-node :variable variable))) +(defstruct (list-node (:include vanilla-node) + (:conc-name node-)) + (head (error "Head argument required") :type node) + (tail (error "Head argument required") :type node)) -(defun* make-list-node ((head node) (tail node)) - (:returns list-node) - (values (make-instance 'list-node :head head :tail tail))) - -(defun* make-lisp-object-node ((object t)) - (:returns lisp-object-node) - (values (make-instance 'lisp-object-node :object object))) +(defstruct (lisp-object-node (:include vanilla-node) + (:conc-name node-)) + (object nil :type t)) (defgeneric* node-children (node) @@ -99,7 +58,7 @@ (list)) (defmethod node-children ((node top-level-node)) - (node-arguments node)) + (top-level-node-arguments node)) (defmethod node-children ((node structure-node)) (node-arguments node)) @@ -175,12 +134,13 @@ (format t "~A>" (lisp-object-to-string (node-object node)))) (defmethod dump-node ((node top-level-node)) - (format t "#<~A/~D" (node-functor node) (node-arity node)) - (let ((*dump-node-indent* 4)) - (dolist (n (node-arguments node)) - (terpri) - (dump-node n))) - (format t ">")) + (with-slots (functor arity arguments) node + (format t "#<~A/~D" functor arity) + (let ((*dump-node-indent* 4)) + (dolist (n arguments) + (terpri) + (dump-node n))) + (format t ">"))) (defmethod print-object ((node node) stream) (let ((*standard-output* stream)) @@ -190,25 +150,27 @@ (defun* parse-list ((contents list)) (:returns node) (if contents - (make-list-node (parse (car contents)) - (parse-list (cdr contents))) - (make-structure-node 'nil 0 ()))) + (make-list-node :head (parse (car contents)) + :tail (parse-list (cdr contents))) + (make-structure-node :functor nil + :arity 0 + :arguments ()))) (defun* parse-list* ((contents list)) (:returns node) (destructuring-bind (next . remaining) contents (if (null remaining) (parse next) - (make-list-node (parse next) - (parse-list* remaining))))) + (make-list-node :head (parse next) + :tail (parse-list* remaining))))) (defun* parse (term &optional top-level-argument) (:returns node) (cond ((variablep term) (if top-level-argument - (make-argument-variable-node term) - (make-variable-node term))) + (make-argument-variable-node :variable term) + (make-variable-node :variable term))) ((symbolp term) (parse (list term))) ; c/0 -> (c/0) ((consp term) @@ -220,11 +182,11 @@ (case functor (list (parse-list arguments)) (list* (parse-list* arguments)) - (t (make-structure-node functor - (length arguments) - (mapcar #'parse arguments)))))) + (t (make-structure-node :functor functor + :arity (length arguments) + :arguments (mapcar #'parse arguments)))))) ((numberp term) - (make-lisp-object-node term)) + (make-lisp-object-node :object term)) (t (error "Cannot parse term ~S into a Prolog term." term)))) (defun* parse-top-level (term) @@ -236,9 +198,10 @@ (error "Cannot parse top-level term ~S because ~S is not a valid functor." term functor)) - (make-top-level-node functor (length arguments) - (mapcar (lambda (a) (parse a t)) - arguments)))) + (make-top-level-node :functor functor + :arity (length arguments) + :arguments (mapcar (lambda (a) (parse a t)) + arguments)))) (t (error "Cannot parse top-level term ~S into a Prolog term." term)))) diff -r a095d20eeebc -r e555488c15e6 src/wam/compiler/2-register-allocation.lisp --- a/src/wam/compiler/2-register-allocation.lisp Fri Jul 15 19:37:17 2016 +0000 +++ b/src/wam/compiler/2-register-allocation.lisp Fri Jul 15 20:16:26 2016 +0000 @@ -182,10 +182,10 @@ (store-variable state variable))) -(defmacro set-when-unbound (instance slot value-form) - (once-only (instance slot) - `(when (not (slot-boundp ,instance ,slot)) - (setf (slot-value ,instance ,slot) ,value-form)))) +(defmacro set-when-nil ((accessor instance) value-form) + (once-only (instance) + `(when (not (,accessor ,instance)) + (setf (,accessor ,instance) ,value-form)))) (defun* variable-anonymous-p ((state allocation-state) (variable symbol)) @@ -219,28 +219,28 @@ (values)) (defmethod allocate-register ((node variable-node) state) - (set-when-unbound node 'register - (allocate-variable-register state (node-variable node)))) + (set-when-nil (node-register node) + (allocate-variable-register state (node-variable node)))) (defmethod allocate-register ((node argument-variable-node) state) - (set-when-unbound node 'secondary-register - (allocate-variable-register state (node-variable node)))) + (set-when-nil (node-secondary-register node) + (allocate-variable-register state (node-variable node)))) (defmethod allocate-register ((node structure-node) state) - (set-when-unbound node 'register - (allocate-nonvariable-register state))) + (set-when-nil (node-register node) + (allocate-nonvariable-register state))) (defmethod allocate-register ((node list-node) state) - (set-when-unbound node 'register - (allocate-nonvariable-register state))) + (set-when-nil (node-register node) + (allocate-nonvariable-register state))) (defmethod allocate-register ((node lisp-object-node) state) - (set-when-unbound node 'register - (allocate-nonvariable-register state))) + (set-when-nil (node-register node) + (allocate-nonvariable-register state))) (defun* allocate-argument-registers ((node top-level-node)) - (loop :for argument :in (node-arguments node) + (loop :for argument :in (top-level-node-arguments node) :for i :from 0 :do (setf (node-register argument) (make-register :argument i)))) @@ -250,7 +250,7 @@ &key nead) ;; JESUS TAKE THE WHEEL (let* - ((actual-arity (node-arity node)) + ((actual-arity (top-level-node-arity node)) (reserved-arity (when nead (clause-nead-arity clause-props))) (reserved-variables (when nead diff -r a095d20eeebc -r e555488c15e6 src/wam/compiler/4-tokenization.lisp --- a/src/wam/compiler/4-tokenization.lisp Fri Jul 15 19:37:17 2016 +0000 +++ b/src/wam/compiler/4-tokenization.lisp Fri Jul 15 20:16:26 2016 +0000 @@ -146,9 +146,10 @@ flatten-query tokenize-assignments ;; We need to shove a CALL/JUMP token onto the end. - (append <> (list (make-instance (if is-tail 'jump-token 'call-token) - :functor (node-functor tree) - :arity (node-arity tree))))))) + (append <> (list (make-instance + (if is-tail 'jump-token 'call-token) + :functor (top-level-node-functor tree) + :arity (top-level-node-arity tree)))))))