mirror of
https://gitlab.com/embeddable-common-lisp/ecl.git
synced 2026-01-06 17:30:41 -08:00
Made the compilation of function calls simpler. Now only two routines, C1CALL-LOCAL and C1CALL-GLOBAL do handle the calling of symbols, and C1FUNCALL is left for the rest.
This commit is contained in:
jjgarcia
parent
7013ab5278
commit
b147bb43e8
5 changed files with 101 additions and 152 deletions
|
|
@ -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:
|
||||
|
|
|
|||
|
|
@ -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))
|
||||
|
|
|
|||
|
|
@ -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.
|
||||
|
|
|
|||
|
|
@ -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.
|
||||
|
|
|
|||
|
|
@ -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;"))
|
||||
|
|
|
|||
Loading…
Add table
Add a link
Reference in a new issue