sfos/ecl
1
0
Fork 0
Code Issues Pull requests Projects Releases Packages Wiki Activity Actions

cmp: small refactor of (funcall/apply (lambda ...) ...) handling

Browse source 
Unify handling of LAMBDA and LAMBDA-BLOCK in c1funcall and c1apply,
split off computation of let bindings and body in
optimize-funcall/apply-lambda into a separate function.

Preliminary work to fix inlining of local closures.
This commit is contained in:
Marius Gerbershagen 2020-05-24 20:34:25 +02:00
parent a5671dcdab
commit a9a63b1d50
3 changed files with 34 additions and 30 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

29
src/cmp/cmpcall.lsp
View file

@ -32,20 +32,21 @@
: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 c1funcall (args)
(check-args-number 'FUNCALL args 1)
(let ((fun (first args))
(arguments (rest args))
fd)
(cond ;; (FUNCALL (LAMBDA ...) ...)
(cond ;; (FUNCALL (LAMBDA ...) ...) or (FUNCALL (EXT::LAMBDA-BLOCK ...) ...)
((and (consp fun)
(eq (first fun) 'LAMBDA))
(optimize-funcall/apply-lambda (cdr fun) arguments nil))
;; (FUNCALL (EXT::LAMBDA-BLOCK ...) ...)
((and (consp fun)
(eq (first fun) 'EXT::LAMBDA-BLOCK))
(setf fun (macroexpand-1 fun))
(optimize-funcall/apply-lambda (cdr fun) arguments nil))
(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))
@ -62,13 +63,11 @@
;; (FUNCALL #'GENERALIZED-FUNCTION-NAME ...)
((si::valid-function-name-p (setq fun (second fun)))
(c1call fun arguments nil))
;; (FUNCALL #'(LAMBDA ...) ...)
((and (consp fun) (eq (first fun) 'LAMBDA))
(optimize-funcall/apply-lambda (rest fun) arguments nil))
;; (FUNCALL #'(EXT::LAMBDA-BLOCK ...) ...)
((and (consp fun) (eq (first fun) 'EXT::LAMBDA-BLOCK))
(setf fun (macroexpand-1 fun))
(optimize-funcall/apply-lambda (rest 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)))))

9
src/cmp/cmpfun.lsp
View file

@ -33,12 +33,9 @@
;; Uses frames instead of lists as last argumennt
(default-apply fun arguments))
((and (consp fun)
(eq (first fun) 'LAMBDA))
(optimize-funcall/apply-lambda (cdr fun) arguments t))
((and (consp fun)
(eq (first fun) 'EXT::LAMBDA-BLOCK))
(setf fun (macroexpand-1 fun))
(optimize-funcall/apply-lambda (cdr fun) arguments t))
(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))

26
src/cmp/cmplam.lsp
View file

@ -573,12 +573,15 @@ The function thus belongs to the type of functions that ecl_make_cfun accepts."
(close-inline-blocks))
(defun optimize-funcall/apply-lambda (lambda-form arguments apply-p
&aux body apply-list apply-var
let-vars extra-stmts all-keys)
;;; Transform a (funcall lambda-form arguments) or (apply lambda-form
;;; arguments) expression into an equivalent let* statement. Returns
;;; the bindings and body as two values.
(defun transform-funcall/apply-into-let* (lambda-form arguments apply-p
&aux body apply-list apply-var
let-vars extra-stmts all-keys)
(multiple-value-bind (requireds optionals rest key-flag keywords
allow-other-keys aux-vars)
(cmp-process-lambda-list (car lambda-form))
(cmp-process-lambda-list (second lambda-form))
(when apply-p
(setf apply-list (first (last arguments))
apply-var (gensym)
@ -656,8 +659,13 @@ The function thus belongs to the type of functions that ecl_make_cfun accepts."
extra-stmts))))
(when (and key-flag (not allow-other-keys))
(push `(si::check-keyword ,rest ',all-keys) extra-stmts))
`(let* ,(nreverse (delete-if-not #'first let-vars))
,@(and apply-var `((declare (ignorable ,apply-var))))
,@(multiple-value-bind (decl body)
(si::find-declarations (rest lambda-form))
(append decl extra-stmts body)))))
(values (nreverse (delete-if-not #'first let-vars))
`(,@(and apply-var `((declare (ignorable ,apply-var))))
,@(multiple-value-bind (decl body)
(si::find-declarations (cddr lambda-form))
(append decl extra-stmts body))))))
(defun optimize-funcall/apply-lambda (lambda-form arguments apply-p)
(multiple-value-bind (bindings body)
(transform-funcall/apply-into-let* lambda-form arguments apply-p)
`(let* ,bindings ,@body)))