From 4d71ab1b2ffbdaeec4246e86552b0a4fc6212713 Mon Sep 17 00:00:00 2001 From: Juan Jose Garcia Ripoll Date: Sat, 5 Jun 2010 22:43:39 +0200 Subject: [PATCH] Rewritten SET-LOC / WT-LOC for a bit more efficiency --- src/cmp/cmploc.lsp | 141 ++++++++++++++++++++++-------------------- src/cmp/cmptables.lsp | 13 ++++ 2 files changed, 88 insertions(+), 66 deletions(-) diff --git a/src/cmp/cmploc.lsp b/src/cmp/cmploc.lsp index d206b11b3..d8ac96472 100644 --- a/src/cmp/cmploc.lsp +++ b/src/cmp/cmploc.lsp @@ -119,76 +119,27 @@ (t (values nil nil)))) -(defun set-loc (loc &aux fd) - (when (eql *destination* loc) - (return-from set-loc)) - (case *destination* - (VALUES - (cond ((eq loc 'VALUES) (return-from set-loc)) - ((uses-values loc) - (wt-nl "cl_env_copy->values[0]=") (wt-coerce-loc :object loc) (wt ";")) - (t - (wt-nl "cl_env_copy->values[0]=") (wt-coerce-loc :object loc) - (wt "; cl_env_copy->nvalues=1;")))) - (VALUE0 - (wt-nl "value0=") (wt-coerce-loc :object loc) (wt ";")) - (RETURN - (cond ((or (eq loc 'VALUES) (uses-values loc)) - (wt-nl "value0=") (wt-coerce-loc :object loc) (wt ";")) - ((eq loc 'VALUE0) (wt-nl "cl_env_copy->nvalues=1;")) - ((eq loc 'RETURN) (return-from set-loc)) - (t - (wt-nl "value0=") (wt-coerce-loc :object loc) - (wt "; cl_env_copy->nvalues=1;")))) - (TRASH - (cond ((uses-values loc) (wt-nl "(void)" loc ";")) - ((and (consp loc) - (eq (first loc) 'C-INLINE) - (fifth loc)) ; side effects? - (wt-nl loc ";")))) - (t (cond - ((var-p *destination*) - (set-var loc *destination*)) - ((vv-p *destination*) - (set-vv loc *destination*)) - ((or (not (consp *destination*)) - (not (symbolp (car *destination*)))) - (baboon)) - ((setq fd (gethash (car *destination*) *set-loc-dispatch-table*)) - (apply fd loc (cdr *destination*))) - ((setq fd (gethash (car *destination*) *wt-loc-dispatch-table*)) - (wt-nl) (apply fd (cdr *destination*)) (wt "= ") - (wt-coerce-loc (loc-representation-type *destination*) loc) - (wt ";")) - (t (baboon :format-control "Unknown location found in SET-LOC~%~S" - :format-arguments (list loc))))))) - +(defun unknown-location (where loc) + (baboon :format-control "Unknown location found in ~A~%~S" + :format-arguments (list where loc))) (defun wt-loc (loc &aux fd) - (cond ((eq loc nil) (wt "Cnil")) - ((eq loc t) (wt "Ct")) - ((eq loc 'RETURN) - (wt "value0")) ; added for last inline-arg - ((eq loc 'VALUES) - (wt "cl_env_copy->values[0]")) - ((eq loc 'VA-ARG) - (wt "va_arg(args,cl_object)")) - ((eq loc 'CL-VA-ARG) - (wt "cl_va_arg(args)")) - ((eq loc 'VALUE0) - (wt "value0")) - ((var-p loc) - (wt-var loc)) + (cond ((consp loc) + (let ((fd (gethash (car loc) *wt-loc-dispatch-table*))) + (if fd + (apply fd (cdr loc)) + (unknown-location 'wt-loc loc)))) + ((symbolp loc) + (let ((txt (gethash loc *wt-loc-dispatch-table* :not-found))) + (when (eq txt :not-found) + (unknown-location 'wt-loc loc)) + (wt txt))) + ((var-p loc) + (wt-var loc)) ((vv-p loc) (wt-vv loc)) - ((or (atom loc) - (not (symbolp (car loc)))) - (baboon :format-control "Unknown location found in WT-LOC~%~S" - :format-arguments (list loc))) - ((setq fd (gethash (car loc) *wt-loc-dispatch-table*)) - (apply fd (cdr loc))) - (t (baboon :format-control "Unknown location found in WT-LOC~%~S" - :format-arguments (list loc))))) + (t + (unknown-location 'wt-loc loc)))) (defun last-call-p () (member *exit* @@ -234,3 +185,61 @@ (defun values-loc (n) (list 'VALUE n)) + +;;; +;;; SET-LOC +;;; + +(defun set-unknown-loc (loc) + (unknown-location 'set-loc *destination*)) + +(defun set-loc (loc &aux fd) + (let ((destination *destination*)) + (cond ((eq destination loc)) + ((symbolp destination) + (funcall (gethash destination *set-loc-dispatch-table* + 'set-unknown-loc) + loc)) + ((var-p destination) + (set-var loc destination)) + ((vv-p destination) + (set-vv loc destination)) + ((atom destination) + (unknown-location 'set-loc destination)) + (t + (let ((fd (gethash (first destination) *set-loc-dispatch-table*))) + (if fd + (apply fd loc (rest destination)) + (progn + (wt-nl) (wt-loc destination) (wt "= ") + (wt-coerce-loc (loc-representation-type *destination*) loc) + (wt ";")))))))) + +(defun set-values-loc (loc) + (cond ((eq loc 'VALUES)) + ((uses-values loc) + (wt-nl "cl_env_copy->values[0]=") (wt-coerce-loc :object loc) (wt ";")) + (t + (wt-nl "cl_env_copy->values[0]=") (wt-coerce-loc :object loc) + (wt "; cl_env_copy->nvalues=1;")))) + +(defun set-value0-loc (loc) + (wt-nl "value0=") (wt-coerce-loc :object loc) (wt ";")) + +(defun set-return-loc (loc) + (cond ((or (eq loc 'VALUES) (uses-values loc)) + (wt-nl "value0=") (wt-coerce-loc :object loc) (wt ";")) + ((eq loc 'VALUE0) + (wt-nl "cl_env_copy->nvalues=1;")) + ((eq loc 'RETURN)) + (t + (wt-nl "value0=") (wt-coerce-loc :object loc) + (wt "; cl_env_copy->nvalues=1;")))) + +(defun set-trash-loc (loc) + (cond ((uses-values loc) (wt-nl "(void)" loc ";")) + ((and (consp loc) + (eq (first loc) 'C-INLINE) + (fifth loc)) ; side effects? + (wt-nl loc ";")))) + diff --git a/src/cmp/cmptables.lsp b/src/cmp/cmptables.lsp index 968ac2d59..f88bf75ad 100644 --- a/src/cmp/cmptables.lsp +++ b/src/cmp/cmptables.lsp @@ -97,6 +97,11 @@ '((bind . bind) (jump-true . set-jump-true) (jump-false . set-jump-false) + + (values . set-values-loc) + (value0 . set-value0-loc) + (return . set-return-loc) + (trash . set-trash-loc) )) (defconstant +wt-loc-dispatch-alist+ @@ -124,6 +129,14 @@ (make-cclosure . wt-make-closure) (structure-ref . wt-structure-ref) + + (nil . "Cnil") + (t . "Ct") + (return . "value0") + (values . "cl_env_copy->values[0]") + (va-arg . "va_arg(args,cl_object)") + (cl-va-arg . "cl_va_arg(args)") + (value0 . "value0") )) (defconstant +c2-dispatch-alist+