diff --git a/src/cmp/cmpinline.lsp b/src/cmp/cmpinline.lsp index cdf13b3fd..c7a1d5782 100644 --- a/src/cmp/cmpinline.lsp +++ b/src/cmp/cmpinline.lsp @@ -353,15 +353,3 @@ (defun args-cause-side-effect (forms) (some #'form-causes-side-effect forms)) - -;;; ---------------------------------------------------------------------- - -(put-sysprop 'FIXNUM 'WT-LOC 'wt-fixnum-loc) -(put-sysprop 'CHARACTER 'WT-LOC 'wt-character-loc) -(put-sysprop 'LONG-FLOAT 'WT-LOC 'wt-long-float-loc) -(put-sysprop 'SHORT-FLOAT 'WT-LOC 'wt-short-float-loc) -(put-sysprop 'BOOLEAN 'WT-LOC 'wt-loc) -(put-sysprop 'T 'WT-LOC 'wt-loc) -;;; Since they are possible locations, we must add: -(put-sysprop 'STRING 'WT-LOC 'wt-loc) -(put-sysprop 'BIT-VECTOR 'WT-LOC 'wt-loc) diff --git a/src/cmp/cmploc.lsp b/src/cmp/cmploc.lsp index 78446d7d6..79b67dffd 100644 --- a/src/cmp/cmploc.lsp +++ b/src/cmp/cmploc.lsp @@ -16,43 +16,45 @@ ;;; NIL ;;; T ;;; fixnum -;;; 'VALUES' +;;; VALUE0 +;;; VALUES ;;; var-object -;;; ( 'VALUE' i ) VALUES(i) -;;; ( 'VV' vv-index ) -;;; ( 'LCL' lcl ) local variable, type unboxed -;;; ( 'TEMP' temp ) local variable, type object -;;; ( 'CALL' fun narg locs fname ) locs are locations containing the arguments -;;; ( 'CALL-LOCAL' fun lex closure args narg fname ) -;;; ( 'C-INLINE' output-type fun/string locs side-effects output-var ) -;;; ( 'CAR' lcl ) -;;; ( 'CADR' lcl ) -;;; ( 'FDEFINITION' vv-index ) -;;; ( 'MAKE-CCLOSURE' cfun ) -;;; ( 'FIXNUM-VALUE' fixnum-value ) -;;; ( 'CHARACTER-VALUE' character-code ) -;;; ( 'LONG-FLOAT-VALUE' long-float-value vv ) -;;; ( 'SHORT-FLOAT-VALUE' short-float-value vv ) -;;; 'VA-ARG' -;;; 'CL-VA-ARG' +;;; ( VALUE i ) VALUES(i) +;;; ( VV vv-index ) +;;; ( LCL lcl ) local variable, type unboxed +;;; ( TEMP temp ) local variable, type object +;;; ( CALL fun narg locs fname ) locs are locations containing the arguments +;;; ( CALL-FIX fun locs fname) similar as CALL, but number of arguments is fixed +;;; ( CALL-LOCAL fun lex closure args narg fname ) +;;; ( C-INLINE output-type fun/string locs side-effects output-var ) +;;; ( COERCE-LOC representation-type location) +;;; ( CAR lcl ) +;;; ( CDR lcl ) +;;; ( CADR lcl ) +;;; ( FDEFINITION vv-index ) +;;; ( MAKE-CCLOSURE cfun ) +;;; ( FIXNUM-VALUE fixnum-value ) +;;; ( CHARACTER-VALUE character-code ) +;;; ( LONG-FLOAT-VALUE long-float-value vv ) +;;; ( SHORT-FLOAT-VALUE short-float-value vv ) +;;; ( STACK-POINTER index ) retrieve a value from the stack +;;; ( SYS:STRUCTURE-REF loc slot-name-vv slot-index ) +;;; ( KEYVARS n ) +;;; VA-ARG +;;; CL-VA-ARG ;;; Valid *DESTINATION* locations are: ;;; -;;; 'RETURN' The value is returned from the current function. -;;; 'RETURN-FIXNUM' -;;; 'RETURN-CHARACTER' -;;; 'RETURN-LONG-FLOAT' -;;; 'RETURN-SHORT-FLOAT' -;;; 'RETURN-OBJECT -;;; 'TRASH' The value may be thrown away. -;;; 'VALUES' +;;; VALUE0 +;;; RETURN Object returned from current function. +;;; TRASH Value may be thrown away. +;;; VALUES Values vector. ;;; var-object -;;; ( 'LCL' lcl ) -;;; ( 'LEX' lex-address ) -;;; ( 'BIND' var alternative ) ; alternative is optional -;;; ( 'JUMP-TRUE' label ) -;;; ( 'JUMP-FALSE' label ) -;;; ( 'PUSH-CATCH-FRAME' ) +;;; ( LCL lcl ) +;;; ( LEX lex-address ) +;;; ( BIND var alternative ) Alternative is optional +;;; ( JUMP-TRUE label ) +;;; ( JUMP-FALSE label ) (defun set-loc (loc &aux fd (is-call (and (consp loc) @@ -65,9 +67,12 @@ ((eq loc 'VALUES) (return-from set-loc)) (t (wt-nl "VALUES(0)=") (wt-coerce-loc :object loc) (wt "; NVALUES=1;")))) + (VALUE0 + (wt-nl "value0=") (wt-coerce-loc :object loc) (wt ";")) (RETURN (cond ((or is-call (eq loc 'VALUES)) (wt-nl "value0=") (wt-coerce-loc :object loc) (wt ";")) + ((eq loc 'VALUE0) (wt-nl "NVALUES=1;")) ((eq loc 'RETURN) (return-from set-loc)) (t (wt-nl "value0=") (wt-coerce-loc :object loc) (wt "; NVALUES=1;")))) @@ -103,6 +108,8 @@ (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)) ((or (not (consp loc)) diff --git a/src/cmp/cmpmulti.lsp b/src/cmp/cmpmulti.lsp index b31c6af55..1130351e0 100644 --- a/src/cmp/cmpmulti.lsp +++ b/src/cmp/cmpmulti.lsp @@ -12,13 +12,19 @@ (in-package "COMPILER") -(defun c1multiple-value-call (args) +(defun c1multiple-value-call (args &aux forms) (check-args-number 'MULTIPLE-VALUE-CALL args 1) - (cond ((endp (rest args)) (c1funcall args)) - ;; FIXME! We should optimize - ;; (multiple-value-call ... (values a b c ...)) - (t (let ((funob (c1expr (first args)))) - (make-c1form 'MULTIPLE-VALUE-CALL funob funob (c1args* (rest args))))))) + (cond + ;; (M-V-C #'FUNCTION) => (FUNCALL #'FUNCTION) + ((endp (rest args)) (c1funcall args)) + ;; (M-V-C #'FUNCTION (VALUES A ... Z)) => (FUNCALL #'FUNCTION A ... Z) + ((and (= (length args) 2) + (consp (setq forms (second args))) + (eq 'VALUES (first forms))) + (c1funcall (list* (first args) (rest forms)))) + ;; More complicated case. + (t (let ((funob (c1expr (first args)))) + (make-c1form 'MULTIPLE-VALUE-CALL funob funob (c1args* (rest args))))))) (defun c2multiple-value-call (funob forms) (let* ((tot (make-lcl-var :rep-type :cl-index)) @@ -60,10 +66,7 @@ ;;; if this occurred in a proclaimed fun. (defun c1values (args) - (if (and args (null (rest args))) - ;; unnecessary code is produced for expression (values nil) - (c1expr (first args)) - (make-c1form* 'VALUES :args (c1args* args)))) + (make-c1form* 'VALUES :args (c1args* args))) (defun c2values (forms) (when (and (eq *destination* 'RETURN-OBJECT) @@ -74,24 +77,45 @@ ~%;But ~a was proclaimed to have single value.~ ~%;Only first one will be assured." (second *current-form*))) - (let ((nv (length forms))) - (declare (fixnum nv)) - (case nv - (0 (wt-nl "value0=Cnil;NVALUES=0;") - (unwind-exit 'RETURN)) - (1 (c2expr (first forms))) - (t (let* ((*inline-blocks* 0) - (forms (nreverse (coerce-locs (inline-args forms))))) - ;; 1) By inlining arguments we make sure that VL has no call to funct. - ;; 2) Reverse args to avoid clobbering VALUES(0) - (wt-nl "NVALUES=" nv ";") - (do ((vl forms (rest vl)) - (i (1- (length forms)) (1- i))) - ((null vl)) - (declare (fixnum i)) - (wt-nl "VALUES(" i ")=" (first vl) ";")) - (unwind-exit 'VALUES) - (close-inline-blocks)))))) + (cond + ;; When the values are not going to be used, then just + ;; process each form separately. + ((eq *destination* 'TRASH) + (mapc #'c2expr forms)) + ;; For (VALUES) we can replace the output with either NIL (if the value + ;; is actually used) and set only NVALUES when the value is the output + ;; of a function. + ((endp forms) + (cond ((eq *destination* 'RETURN) + (wt-nl "value0=Cnil; NVALUES=0;") + (unwind-exit 'RETURN)) + ((eq *destination* 'VALUES) + (wt-nl "VALUES(0)=Cnil; NVALUES=0;") + (unwind-exit 'VALUES)) + (t + (unwind-exit 'NIL)))) + ;; For a single form, we must simply ensure that we only take a single + ;; value of those that the function may output. + ((endp (rest forms)) + (let ((*destination* 'VALUE0)) + (c2expr* (first forms))) + (unwind-exit 'VALUE0)) + ;; In all other cases, we store the values in the VALUES vector, + ;; and force the compiler to retrieve anything out of it. + (t + (let* ((nv (length forms)) + (*inline-blocks* 0) + (forms (nreverse (coerce-locs (inline-args forms))))) + ;; By inlining arguments we make sure that VL has no call to funct. + ;; Reverse args to avoid clobbering VALUES(0) + (wt-nl "NVALUES=" nv ";") + (do ((vl forms (rest vl)) + (i (1- (length forms)) (1- i))) + ((null vl)) + (declare (fixnum i)) + (wt-nl "VALUES(" i ")=" (first vl) ";")) + (unwind-exit 'VALUES) + (close-inline-blocks))))) (defun c1multiple-value-setq (args &aux (info (make-info)) (vrefs nil) (vars nil) (temp-vars nil) (late-bindings nil))