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

Merge branch 'inline-closure' into 'develop'

Browse source 
Fix inlining of closures (2nd try)

Closes #577

See merge request embeddable-common-lisp/ecl!209
This commit is contained in:
Daniel Kochmański 2020-07-18 18:29:06 +00:00
commit 329b37d833
5 changed files with 77 additions and 47 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)))))

22
src/cmp/cmpeval.lsp
View file

@ -97,15 +97,31 @@
`(funcall ,can-inline ,@args)))
(t (c1call-global fname args))))
(defun inline-local (lambda fun args)
(declare (si::c-local))
(let ((*inline-max-depth* (1- *inline-max-depth*))
(setjmps *setjmps*)
(*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)
(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
;; environment in which the function was defined to get
;; inlining of closures right.
(let ((*cmp-env* (cmp-env-copy (fun-cmp-env fun))))
(mapc #'push-vars let-vars)
(process-let-body 'LET* let-vars let-inits specials other-decls body setjmps))))))
(defun c1call-local (fname fun args)
(declare (si::c-local))
(let ((lambda (fun-lambda-expression fun)))
(when (and lambda
(declared-inline-p fname)
(plusp *inline-max-depth*))
(return-from c1call-local
(let ((*inline-max-depth* (1- *inline-max-depth*)))
`(funcall #',lambda ,@args)))))
(return-from c1call-local (inline-local lambda fun args))))
(let* ((forms (c1args* args))
(return-type (or (get-local-return-type fun) 'T))
(arg-types (get-local-arg-types 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)))

38
src/cmp/cmplet.lsp
View file

@ -59,22 +59,18 @@
(t
(c1let/let* 'let* bindings args)))))
;; Processing of a let form is split in two stages:
;; - processing bindings
;; - processing the body
;; This allows reusing the below functions for inlined closures. These
;; are transformed in a let statement for which the body needs to be
;; compiled in a different lexical environment than the bindings.
(defun c1let/let* (let/let* bindings body)
(let* ((setjmps *setjmps*)
(*cmp-env* (cmp-env-copy)))
(multiple-value-bind (vars forms body)
(multiple-value-bind (vars forms specials other-decls body)
(process-let-bindings let/let* bindings body)
;; Try eliminating unused variables, replace constant ones, etc.
(multiple-value-setq (vars forms)
(c1let-optimize-read-only-vars vars forms body))
;; Verify that variables are referenced and assign final boxed / unboxed type
(mapc #'check-vref vars)
(let ((sp-change (some #'global-var-p vars)))
(make-c1form* let/let*
:type (c1form-type body)
:volatile (not (eql setjmps *setjmps*))
:local-vars vars
:args vars forms body)))))
(process-let-body let/let* vars forms specials other-decls body setjmps))))
(defun invalid-let-bindings (let/let* bindings)
(cmperr "Syntax error in ~A bindings:~%~4I~A"
@ -123,8 +119,22 @@
(when (eq let/let* 'LET)
(mapc #'push-vars vars))
(check-vdecl (mapcar #'var-name vars) types ignoreds)
(mapc #'cmp-env-declare-special specials)
(values vars forms (c1decl-body other-decls body)))))
(values vars forms specials other-decls body))))
(defun process-let-body (let/let* vars forms specials other-decls body setjmps)
(mapc #'cmp-env-declare-special specials)
(setf body (c1decl-body other-decls body))
;; Try eliminating unused variables, replace constant ones, etc.
(multiple-value-setq (vars forms)
(c1let-optimize-read-only-vars vars forms body))
;; Verify that variables are referenced and assign final boxed / unboxed type
(mapc #'check-vref vars)
(let ((sp-change (some #'global-var-p vars)))
(make-c1form* let/let*
:type (c1form-type body)
:volatile (not (eql setjmps *setjmps*))
:local-vars vars
:args vars forms body)))
(defun c1let-optimize-read-only-vars (all-vars all-forms body)
(loop with base = (list body)