diff --git a/src/cmp/cmpcall.lsp b/src/cmp/cmpcall.lsp index 45de5d0ac..4a38cd759 100644 --- a/src/cmp/cmpcall.lsp +++ b/src/cmp/cmpcall.lsp @@ -31,90 +31,58 @@ (or (sch-local-macro name) (macro-function name))) -(defun c1funob (fun &aux fd function) - ;; fun is an expression appearing in functional position, in particular - ;; (FUNCTION (LAMBDA ..)) - (when (and (consp fun) - (symbolp (first fun)) - (cmp-macro-function (first fun))) - (setq fun (cmp-macroexpand fun))) - (cond ((not (and (consp fun) - (eq (first fun) 'FUNCTION) - (consp (cdr fun)) - (endp (cddr fun)))) - (make-c1form* 'ORDINARY :sp-change t :args (c1expr fun))) - ((si::valid-function-name-p (setq function (second fun))) - (or (c1call-local function) - (make-c1form* 'GLOBAL - :sp-change (not (get-sysprop function 'NO-SP-CHANGE)) - :args function))) - ((and (consp function) - (eq (first function) 'LAMBDA) - (consp (rest function))) - ;; Don't create closure boundary like in c1function - ;; since funob is used in this same environment - (let ((lambda-expr (c1lambda-expr (rest function)))) - (make-c1form 'LAMBDA lambda-expr lambda-expr (next-cfun)))) - ((and (consp function) - (eq (first function) 'LAMBDA-BLOCK) - (consp (rest function))) - ;; Don't create closure boundary like in c1function - ;; since funob is used in this same environment - (let* ((block-name (second function))) - (let ((lambda-expr (c1lambda-expr (cddr function) block-name))) - (make-c1form 'LAMBDA lambda-expr lambda-expr (next-cfun))))) - (t (cmperr "Malformed function: ~A" fun)))) - (defun c1funcall (args) (check-args-number 'FUNCALL args 1) (let ((fun (first args)) (arguments (rest args))) - (cond ((and (consp fun) + (cond ;; (FUNCALL (LAMBDA ...) ...) + ((and (consp fun) (eq (first fun) 'LAMBDA)) (c1expr (optimize-funcall/apply-lambda (cdr fun) arguments nil))) - ((and (consp fun) + ;; (FUNCALL (LAMBDA-BLOCK ...) ...) + ((and (consp fun) (eq (first fun) 'LAMBDA-BLOCK)) (setf fun (macroexpand-1 fun)) (c1expr (optimize-funcall/apply-lambda (cdr fun) arguments nil))) - ((and (consp fun) - (eq (first fun) 'FUNCTION) - (consp (second fun)) - (member (caadr fun) '(LAMBDA LAMBDA-BLOCK))) - (c1funcall (list* (second fun) arguments))) + ;; (FUNCALL lisp-expression ...) + ((not (and (consp fun) + (eq (first fun) 'FUNCTION))) + (make-c1form* 'FUNCALL :args (c1expr fun) (c1args* arguments))) + ;; (FUNCALL #'GENERALIZED-FUNCTION-NAME ...) + ((si::valid-function-name-p (setq fun (second fun))) + (or (c1call-local fun arguments) + (c1call-global fun arguments))) + ;; (FUNCALL #'(LAMBDA ...) ...) + ((and (consp fun) (eq (first fun) 'LAMBDA)) + (c1expr (optimize-funcall/apply-lambda (rest fun) arguments nil))) + ;; (FUNCALL #'(LAMBDA-BLOCK ...) ...) + ((and (consp fun) (eq (first fun) 'LAMBDA-BLOCK)) + (setf fun (macroexpand-1 fun)) + (c1expr (optimize-funcall/apply-lambda (rest fun) arguments nil))) (t - (make-c1form* 'FUNCALL :args (c1funob fun) (c1args* arguments)))))) + (cmperr "Malformed function name: ~A" fun))))) -(defun c2funcall (funob args &optional loc narg - &aux (form (c1form-arg 0 funob))) +(defun c2funcall (form args &optional loc narg) ;; Usually, ARGS holds a list of forms, which are arguments to the ;; function. If, however, the arguments are on VALUES, ;; ARGS should be set to the symbol ARGS-PUSHED, and NARG to a location ;; containing the number of arguments. ;; LOC is the location of the function object (created by save-funob). - (case (c1form-name funob) - (GLOBAL (c2call-global form args loc t narg)) - (LOCAL (c2call-local form args narg)) - (ORDINARY ;;; An ordinary expression. In this case, if - ;;; arguments are already on VALUES, then - ;;; LOC cannot be NIL. Callers of C2FUNCALL must be - ;;; responsible for maintaining this condition. - (let ((fun (c1form-arg 0 form))) + (case (c1form-name form) + (GLOBAL (c2call-global (c1form-arg 0 form) args loc t narg)) + (LOCAL (c2call-local (c1form-arg 0 form) args narg)) + ;; An ordinary expression. In this case, if arguments are already on + ;; VALUES, then LOC cannot be NIL. Callers of C2FUNCALL must be + ;; responsible for maintaining this condition. + (otherwise + (let ((*inline-blocks* 0) + (*temp* *temp*)) (unless loc - (cond ((eq (c1form-name form) 'LOCATION) (setq loc fun)) - ((and (eq (c1form-name form) 'VAR) - (not (var-changed-in-forms fun args))) - (setq loc fun)) - (t - (setq loc (make-temp-var)) - (let ((*destination* loc)) (c2expr* form))))) - - (let ((*inline-blocks* 0)) - (c2call-unknown-global nil (if (eq args 'ARGS-PUSHED) - args - (inline-args args)) loc nil narg) - (close-inline-blocks)))) - (otherwise (baboon)) - )) + (setf loc (maybe-save-value form args))) + (c2call-unknown-global nil (if (eq args 'ARGS-PUSHED) + args + (inline-args args)) loc nil narg) + (close-inline-blocks))))) (defun maybe-push-args (args) (when (or (eq args 'ARGS-PUSHED) @@ -268,25 +236,20 @@ ) ) -;;; Functions that use SAVE-FUNOB should rebind *temp*. -(defun save-funob (funob) - (case (c1form-name funob) - ((LAMBDA LOCAL)) - (GLOBAL - (let ((fun-name (c1form-arg 0 funob))) - (unless (and (inline-possible fun-name) - (or (and (symbolp fun-name) (get-sysprop fun-name 'Lfun)) - (assoc fun-name *global-funs* :test #'same-fname-p))) - (let* ((temp (make-temp-var)) - (fdef (list 'FDEFINITION fun-name))) - (wt-nl temp "=" fdef ";") - temp)))) - (ORDINARY (let* ((temp (make-temp-var)) - (*destination* temp)) - (c2expr* (c1form-arg 0 funob)) - temp)) - (otherwise (baboon)) - )) +;;; Functions that use MAYBE-SAVE-VALUE should rebind *temp*. +(defun maybe-save-value (value &optional (other-forms nil other-forms-flag)) + (let ((name (c1form-name value))) + (cond ((eq name 'LOCATION) + (c1form-arg 0 value)) + ((and (eq name 'VAR) + other-forms-flag + (not (var-changed-in-forms (c1form-arg 0 value) other-forms))) + (c1form-arg 0 value)) + (t + (let* ((temp (make-temp-var)) + (*destination* temp)) + (c2expr* value) + temp))))) ;;; ;;; call-loc: diff --git a/src/cmp/cmpeval.lsp b/src/cmp/cmpeval.lsp index 56f963bbe..f256cc9cf 100644 --- a/src/cmp/cmpeval.lsp +++ b/src/cmp/cmpeval.lsp @@ -48,28 +48,7 @@ (defun c1call-symbol (fname args &aux fd) (cond ((setq fd (get-sysprop fname 'c1special)) (funcall fd args)) - ((setq fd (c1call-local fname)) - (let* ((forms (c1args* args)) - (fun (c1form-arg 0 fd)) - (return-type (or (get-local-return-type fun) 'T))) - (let ((arg-types (get-local-arg-types fun))) - ;; Add type information to the arguments. - (when arg-types - (let ((fl nil)) - (dolist (form forms) - (cond ((endp arg-types) (push form fl)) - (t (push (and-form-type (car arg-types) form (car args) - :safe "In a call to ~a" fname) - fl) - (pop arg-types) - (pop args)))) - (setq forms (nreverse fl))))) - (make-c1form* 'CALL-LOCAL - :sp-change t - :referred-vars (c1form-referred-vars fd) - :local-referred (c1form-local-referred fd) - :type return-type - :args fun forms))) + ((c1call-local fname args)) ((setq fd (sch-local-macro fname)) (c1expr (cmp-expand-macro fd fname args))) ((and (setq fd (get-sysprop fname 'C1)) @@ -101,6 +80,32 @@ ) (t (c1call-global fname args)))) +(defun c1call-local (fname args) + (let ((fun (local-function-ref fname))) + (when fun + (let* ((forms (c1args* args)) + (referred-vars (list (fun-var fun))) + (referred-local (list (fun-var fun))) + (return-type (or (get-local-return-type fun) 'T)) + (arg-types (get-local-arg-types fun))) + ;; Add type information to the arguments. + (when arg-types + (let ((fl nil)) + (dolist (form forms) + (cond ((endp arg-types) (push form fl)) + (t (push (and-form-type (car arg-types) form (car args) + :safe "In a call to ~a" fname) + fl) + (pop arg-types) + (pop args)))) + (setq forms (nreverse fl)))) + (make-c1form* 'CALL-LOCAL + :sp-change t + :referred-vars referred-local + :local-referred referred-vars + :type return-type + :args fun forms))))) + (defun c1call-global (fname args) (let* ((forms (c1args* args)) (return-type (or (get-return-type fname) 'T))) @@ -133,24 +138,13 @@ (defun c2expr (form &aux (name (c1form-name form)) (args (c1form-args form))) (if (eq name 'CALL-GLOBAL) -;;; ---------------------------------------------------------------------- -;;; Added optimization for proclaimed functions: Beppe -;;; ---------------------------------------------------------------------- - (let ((fname (car *tail-recursion-info*))) - (c2call-global (first args) (second args) nil (destination-type))) -#| (if (and - (last-call-p) - (symbolp fname) ; locally defined function are - ; represented as variables - (get-sysprop fname 'PROCLAIMED-FUNCTION)) - (get-sysprop fname 'PROCLAIMED-RETURN-TYPE) - (c1form-type form)))))|# - (let ((dispatch (get-sysprop name 'C2))) - (if (or (eq name 'LET) (eq name 'LET*)) - (let ((*volatile* (c1form-volatile* form))) - (declare (special *volatile*)) - (apply dispatch args)) - (apply dispatch args))))) + (c2call-global (first args) (second args) nil (destination-type)) + (let ((dispatch (get-sysprop name 'C2))) + (if (or (eq name 'LET) (eq name 'LET*)) + (let ((*volatile* (c1form-volatile* form))) + (declare (special *volatile*)) + (apply dispatch args)) + (apply dispatch args))))) (defun c2expr* (form) (let* ((*exit* (next-label)) diff --git a/src/cmp/cmpflet.lsp b/src/cmp/cmpflet.lsp index 1e80a9a5a..3cf054913 100644 --- a/src/cmp/cmpflet.lsp +++ b/src/cmp/cmpflet.lsp @@ -261,14 +261,6 @@ (var-kind var) 'LEXICAL)))) (return fun))))) -(defun c1call-local (fname) - ;; used by c1funob and c1call-symbol - (let ((fun (local-function-ref fname))) - (when fun - (make-c1form* 'LOCAL :local-referred (list (fun-var fun)) - :referred-vars (list (fun-var fun)) - :args fun)))) - (defun sch-local-fun (fname) ;; Returns fun-ob for the local function (not locat macro) named FNAME, ;; if any. Otherwise, returns FNAME itself. diff --git a/src/cmp/cmpmulti.lsp b/src/cmp/cmpmulti.lsp index 4fdbcc35c..50d9d74c9 100644 --- a/src/cmp/cmpmulti.lsp +++ b/src/cmp/cmpmulti.lsp @@ -12,17 +12,18 @@ (in-package "COMPILER") -(defun c1multiple-value-call (args &aux info funob) +(defun c1multiple-value-call (args) (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 (setq funob (c1funob (first args))) - (make-c1form 'MULTIPLE-VALUE-CALL funob funob (c1args* (rest args)))))) + (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)) - (loc (save-funob funob))) + (let* ((tot (make-lcl-var :rep-type :cl-index)) + (*temp* *temp*) + (loc (maybe-save-value funob forms))) (wt-nl "{ cl_index " tot "=0;") (let ((*unwind-exit* `((STACK ,tot) ,@*unwind-exit*))) (let ((*destination* 'VALUES)) @@ -50,7 +51,7 @@ (dolist (form forms) (c2expr* form))) (wt-nl "cl_stack_pop_values(" nr ");}") - (unwind-exit 'VALUES))))) + (unwind-exit 'VALUES)))) ;;; Beppe: ;;; this is the WRONG way to handle 1 value problem. diff --git a/src/cmp/cmptop.lsp b/src/cmp/cmptop.lsp index 30d2b2388..2c7a53efa 100644 --- a/src/cmp/cmptop.lsp +++ b/src/cmp/cmptop.lsp @@ -572,22 +572,21 @@ (defun c1load-time-value (args) (check-args-number 'LOAD-TIME-VALUE args 1 2) - (let ((form (first args))) + (let ((form (first args)) + loc) (cond ((listp form) - (incf *next-vv*) - (push (make-c1form* 'LOAD-TIME-VALUE :args *next-vv* (c1expr form)) - *load-time-values*) - (add-object 0 t) - (make-c1form* 'LOCATION :type t - :args `(VV ,(format nil "VV[~d]" *next-vv*)))) + (setf loc (data-empty-loc)) + (push (make-c1form* 'LOAD-TIME-VALUE :args loc (c1expr form)) + *load-time-values*)) (t - (add-object (cmp-eval form)))))) + (setf loc (add-object (cmp-eval form))))) + (make-c1form* 'LOCATION :type t :args loc))) -(defun t2load-time-value (ndx form) +(defun t2load-time-value (vv-loc form) (let* ((*exit* (next-label)) (*unwind-exit* (list *exit*)) - (*destination* (list 'VV ndx))) - (c2expr form) - (wt-label *exit*))) + (*destination* vv-loc)) + (c2expr form) + (wt-label *exit*))) (defun t2declare (vv) (wt-nl vv "->symbol.stype=(short)stp_special;"))