mirror of
https://gitlab.com/embeddable-common-lisp/ecl.git
synced 2026-01-18 23:32:17 -08:00
cmp: cmppass1-call: refactor first pass operators funcall and apply
This commit is contained in:
Daniel Kochmański
parent
18e1a69ba7
commit
a35b89866a
1 changed files with 77 additions and 68 deletions
|
|
@ -20,51 +20,72 @@
|
|||
(defun unoptimized-funcall (fun arguments)
|
||||
(let ((l (length arguments)))
|
||||
(if (<= l si:c-arguments-limit)
|
||||
(make-c1form* 'FUNCALL :sp-change t :side-effects t
|
||||
:args (c1expr fun) (c1args* arguments))
|
||||
(make-c1form* 'CL:FUNCALL :sp-change t :side-effects t
|
||||
:args (c1expr fun) (c1args* arguments))
|
||||
(unoptimized-long-call fun arguments))))
|
||||
|
||||
(defun macroexpand-lambda-block (lambda)
|
||||
(if (eq (first lambda) 'EXT::LAMBDA-BLOCK)
|
||||
(macroexpand-1 lambda)
|
||||
lambda))
|
||||
(defun optimized-lambda-call (lambda-form arguments apply-p)
|
||||
(multiple-value-bind (bindings body)
|
||||
(transform-funcall/apply-into-let* lambda-form arguments apply-p)
|
||||
`(let* ,bindings ,@body)))
|
||||
|
||||
(defun try-optimized-lambda-call (fun args apply-p)
|
||||
(unless (consp fun)
|
||||
(return-from try-optimized-lambda-call nil))
|
||||
(when (function-form-p fun)
|
||||
(setf fun (second fun)))
|
||||
(if (and (consp fun)
|
||||
(member (first fun) '(cl:lambda ext:lambda-block)))
|
||||
(optimized-lambda-call fun args apply-p)
|
||||
nil))
|
||||
|
||||
(defun try-macro-expression-call (fun args)
|
||||
(unless (consp fun)
|
||||
(return-from try-macro-expression-call nil))
|
||||
(let* ((name (first fun))
|
||||
(fd (and (symbolp name)
|
||||
;; We do not want to macroexpand 'CL:THE
|
||||
(not (eq name 'CL:THE))
|
||||
(cmp-macro-function name))))
|
||||
(if fd
|
||||
(c1funcall (list* (cmp-expand-macro fd fun) args))
|
||||
nil)))
|
||||
|
||||
(defun try-function-special-call (fun args)
|
||||
(unless (function-form-p fun)
|
||||
(return-from try-function-special-call nil))
|
||||
(let ((fname (second fun)))
|
||||
(if (si:valid-function-name-p fname)
|
||||
(c1call fname args nil)
|
||||
(cmperr "Malformed function name: ~A." fun))))
|
||||
|
||||
(defun not-a-closure-p (fname)
|
||||
(declare (si::c-local))
|
||||
(not (and (fboundp fname) (nth-value 1 (function-lambda-expression (fdefinition fname))))))
|
||||
|
||||
(defun function-form-p (form)
|
||||
(declare (si::c-local))
|
||||
(if (and (consp form)
|
||||
(eq (first form) 'CL:FUNCTION))
|
||||
(prog1 t
|
||||
(check-args-number 'CL:FUNCTION (rest form) 1 1))
|
||||
nil))
|
||||
|
||||
(defun c1funcall (args)
|
||||
(check-args-number 'FUNCALL args 1)
|
||||
(let ((fun (first args))
|
||||
(arguments (rest args))
|
||||
fd)
|
||||
(cond ;; (FUNCALL (LAMBDA ...) ...) or (FUNCALL (EXT::LAMBDA-BLOCK ...) ...)
|
||||
((and (consp fun)
|
||||
(member (first fun) '(LAMBDA EXT::LAMBDA-BLOCK)))
|
||||
(optimize-funcall/apply-lambda (macroexpand-lambda-block fun)
|
||||
arguments nil))
|
||||
;; (FUNCALL atomic-expression ...)
|
||||
((atom fun)
|
||||
(unoptimized-funcall fun arguments))
|
||||
;; (FUNCALL macro-expression ...)
|
||||
((let ((name (first fun)))
|
||||
(setq fd (and (symbolp name)
|
||||
;; We do not want to macroexpand 'THE
|
||||
(not (eq name 'THE))
|
||||
(cmp-macro-function name))))
|
||||
(c1funcall (list* (cmp-expand-macro fd fun) arguments)))
|
||||
;; (FUNCALL lisp-expression ...)
|
||||
((not (eq (first fun) 'FUNCTION))
|
||||
(unoptimized-funcall fun arguments))
|
||||
;; (FUNCALL #'GENERALIZED-FUNCTION-NAME ...)
|
||||
((si::valid-function-name-p (setq fun (second fun)))
|
||||
(c1call fun arguments nil))
|
||||
;; (FUNCALL #'(LAMBDA ...) ...) or (FUNCALL #'(EXT::LAMBDA-BLOCK ...) ...)
|
||||
((and (consp fun)
|
||||
(member (first fun) '(LAMBDA EXT::LAMBDA-BLOCK)))
|
||||
(optimize-funcall/apply-lambda (macroexpand-lambda-block fun)
|
||||
arguments nil))
|
||||
(t
|
||||
(cmperr "Malformed function name: ~A" fun)))))
|
||||
(check-args-number 'CL:FUNCALL args 1)
|
||||
(destructuring-bind (fun . arguments) args
|
||||
(or ;; (FUNCALL (LAMBDA ...) ...) or (FUNCALL (EXT:LAMBDA-BLOCK ...) ...)
|
||||
;; (FUNCALL #'(LAMBDA ...) ...) or (FUNCALL #'(EXT:LAMBDA-BLOCK ...) ...)
|
||||
(try-optimized-lambda-call fun arguments nil)
|
||||
;; (FUNCALL macro-expression ...)
|
||||
(try-macro-expression-call fun arguments)
|
||||
;; (FUNCALL (FUNCTION function-name) ...)
|
||||
(try-function-special-call fun arguments)
|
||||
;; (FUNCALL lisp-expression ...) or (FUNCALL atomic-expression ...)
|
||||
(unoptimized-funcall fun arguments))))
|
||||
|
||||
(defun c1multiple-value-call (args &aux forms)
|
||||
(check-args-number 'MULTIPLE-VALUE-CALL args 1)
|
||||
(check-args-number 'CL:MULTIPLE-VALUE-CALL args 1)
|
||||
(cond
|
||||
;; (M-V-C #'FUNCTION) => (FUNCALL #'FUNCTION)
|
||||
((endp (rest args))
|
||||
|
|
@ -72,7 +93,7 @@
|
|||
;; (M-V-C #'FUNCTION (VALUES A ... Z)) => (FUNCALL #'FUNCTION A ... Z)
|
||||
((and (= (length args) 2)
|
||||
(consp (setq forms (second args)))
|
||||
(eq 'VALUES (first forms)))
|
||||
(eq 'CL:VALUES (first forms)))
|
||||
(c1funcall (list* (first args) (rest forms))))
|
||||
;; More complicated case.
|
||||
(t
|
||||
|
|
@ -85,35 +106,23 @@
|
|||
(si::apply-from-stack-frame ,frame ,function)))))))
|
||||
|
||||
(defun c1apply (args)
|
||||
(check-args-number 'APPLY args 2)
|
||||
(check-args-number 'CL:APPLY args 2)
|
||||
(flet ((default-apply (fun arguments)
|
||||
(let ((form (c1funcall (list* '#'APPLY fun arguments))))
|
||||
(when (and (consp fun) (eq (first fun) 'FUNCTION))
|
||||
(when (function-form-p fun)
|
||||
(let* ((fname (second fun))
|
||||
(type (get-return-type fname)))
|
||||
(when type
|
||||
(setf (c1form-type form) type))))
|
||||
form)))
|
||||
(let* ((fun (first args))
|
||||
(arguments (rest args)))
|
||||
(cond ((eql (first (last arguments)) 'clos:.combined-method-args.)
|
||||
;; Uses frames instead of lists as last argumennt
|
||||
(default-apply fun arguments))
|
||||
((and (consp fun)
|
||||
(member (first fun) '(LAMBDA EXT::LAMBDA-BLOCK)))
|
||||
(optimize-funcall/apply-lambda (macroexpand-lambda-block fun)
|
||||
arguments t))
|
||||
((and (consp fun)
|
||||
(eq (first fun) 'FUNCTION)
|
||||
(consp (second fun))
|
||||
(member (caadr fun) '(LAMBDA EXT::LAMBDA-BLOCK)))
|
||||
(c1apply (list* (second fun) arguments)))
|
||||
(t
|
||||
(default-apply fun arguments))))))
|
||||
|
||||
(defun not-a-closure-p (fname)
|
||||
(declare (si::c-local))
|
||||
(not (and (fboundp fname) (nth-value 1 (function-lambda-expression (fdefinition fname))))))
|
||||
form))
|
||||
(last-argument-is-frame-p (arguments)
|
||||
;; Uses frames instead of lists as last argument. ;; gross hack!
|
||||
(eql (first (last arguments)) 'clos:.combined-method-args.)))
|
||||
(destructuring-bind (fun . arguments) args
|
||||
(if (last-argument-is-frame-p arguments)
|
||||
(default-apply fun arguments)
|
||||
(or (try-optimized-lambda-call fun arguments t)
|
||||
(default-apply fun arguments))))))
|
||||
|
||||
(defun c1call (fname args macros-allowed &aux fd success can-inline)
|
||||
(cond ((> (length args) si::c-arguments-limit)
|
||||
|
|
@ -151,9 +160,8 @@
|
|||
(not (fun-closure fd)))
|
||||
(cmpnote "Inlining ~a" fname)
|
||||
(inline-local (fun-lambda-expression fd) fd args))
|
||||
((and (consp can-inline)
|
||||
(not-a-closure-p fname)
|
||||
(eq (first can-inline) 'function))
|
||||
((and (function-form-p can-inline)
|
||||
(not-a-closure-p fname))
|
||||
(let ((*inline-max-depth* (1- *inline-max-depth*)))
|
||||
(cmpnote "Inlining ~a" fname)
|
||||
`(funcall ,can-inline ,@args)))
|
||||
|
|
@ -167,8 +175,7 @@
|
|||
(*cmp-env* (cmp-env-copy)))
|
||||
;; To inline the function, we transform it into a let* statement.
|
||||
(multiple-value-bind (bindings body)
|
||||
(transform-funcall/apply-into-let* (macroexpand-lambda-block lambda)
|
||||
args nil)
|
||||
(transform-funcall/apply-into-let* lambda args nil)
|
||||
(multiple-value-bind (let-vars let-inits specials other-decls body)
|
||||
(process-let-bindings 'LET* bindings body)
|
||||
;; We have to compile the function body in the same
|
||||
|
|
@ -251,6 +258,8 @@
|
|||
(defun transform-funcall/apply-into-let* (lambda-form arguments apply-p
|
||||
&aux apply-list apply-var
|
||||
let-vars extra-stmts all-keys)
|
||||
(when (eq (first lambda-form) 'ext:lambda-block)
|
||||
(setf lambda-form (macroexpand-1 lambda-form)))
|
||||
(multiple-value-bind (requireds optionals rest key-flag keywords
|
||||
allow-other-keys aux-vars)
|
||||
(cmp-process-lambda-list (second lambda-form))
|
||||
|
|
|
|||
Loading…
Add table
Add a link
Reference in a new issue