From a9065d1d8e3415fb92ef3b562545e2f6f8ccff08 Mon Sep 17 00:00:00 2001 From: Marius Gerbershagen Date: Wed, 18 Mar 2020 22:00:57 +0100 Subject: [PATCH 1/4] cmp: fix closure type for local functions calling closures When a local function calls a closure it has to be a closure too. Thus when updating the closure type for a function f, we have to possibly update also all functions referencing f. Fixes #545. --- src/cmp/cmpflet.lsp | 3 ++- src/tests/normal-tests/compiler.lsp | 23 +++++++++++++++++++++++ 2 files changed, 25 insertions(+), 1 deletion(-) diff --git a/src/cmp/cmpflet.lsp b/src/cmp/cmpflet.lsp index 6d50babce..116505035 100644 --- a/src/cmp/cmpflet.lsp +++ b/src/cmp/cmpflet.lsp @@ -151,13 +151,14 @@ ;; This recursive algorithm is guaranteed to stop when functions ;; do not change. (let ((new-type (compute-closure-type fun)) - (to-be-updated (fun-child-funs fun))) + to-be-updated) ;; Same type (when (eq new-type old-type) (return-from update-fun-closure-type nil)) (when (fun-global fun) (cmpnote "Function ~A is global but is closed over some variables.~%~{~A ~}" (fun-name fun) (mapcar #'var-name (fun-referenced-vars fun)))) + (setf to-be-updated (append (fun-child-funs fun) (fun-referencing-funs fun))) (setf (fun-closure fun) new-type) ;; All external, non-global variables become of type closure (when (eq new-type 'CLOSURE) diff --git a/src/tests/normal-tests/compiler.lsp b/src/tests/normal-tests/compiler.lsp index ee960b529..1dfd6d0ae 100644 --- a/src/tests/normal-tests/compiler.lsp +++ b/src/tests/normal-tests/compiler.lsp @@ -1606,3 +1606,26 @@ (check-fn (make-fn (1+ si::c-arguments-limit))) (check-fn (make-fn (1- si::c-arguments-limit))) (check-fn (make-fn si::c-arguments-limit)))) + +;;; Date 2020-03-18 +;;; URL: https://gitlab.com/embeddable-common-lisp/ecl/issues/545 +;;; Description +;;; +;;; The closure type for local functions calling global closures was +;;; not determined correctly to also be a global closure. +(test cmp.0075.local-fun.closure-type + (ext:with-clean-symbols (*function*) + (defvar *function*) + (let ((result + (funcall + (compile nil + (lambda (b) + (flet ((%f10 () b)) + (flet ((%f4 () (%f10))) + (incf b) + (setf *function* #'%f10) ; makes a global + ; closure out of %f10 + (%f4))))) + 3))) + (is (eq result 4)) + (is (eq (funcall *function*) 4))))) From dda466dd0e422b91ae85c5031b4a666721fa157b Mon Sep 17 00:00:00 2001 From: Marius Gerbershagen Date: Fri, 20 Mar 2020 21:29:18 +0100 Subject: [PATCH 2/4] cmp: allow :allow-other-keys for functions with &key but zero keywords Functions such as (defun f (&key) ...) would give an error when called like (f :allow-other-keys ...). --- src/cmp/cmplam.lsp | 23 ++++++++++++----------- 1 file changed, 12 insertions(+), 11 deletions(-) diff --git a/src/cmp/cmplam.lsp b/src/cmp/cmplam.lsp index b84dbabeb..3777d35a5 100644 --- a/src/cmp/cmplam.lsp +++ b/src/cmp/cmplam.lsp @@ -361,12 +361,13 @@ The function thus belongs to the type of functions that ecl_make_cfun accepts." &aux (requireds (first lambda-list)) (optionals (second lambda-list)) (rest (third lambda-list)) rest-loc + (key-flag (fourth lambda-list)) (keywords (fifth lambda-list)) (allow-other-keys (sixth lambda-list)) (nreq (length requireds)) (nopt (/ (length optionals) 3)) (nkey (/ (length keywords) 4)) - (varargs (or optionals rest keywords allow-other-keys)) + (varargs (or optionals rest key-flag allow-other-keys)) (fname-in-ihs-p (or (policy-debug-variable-bindings) (and (policy-debug-ihs-frame) (or description fname)))) @@ -380,13 +381,13 @@ The function thus belongs to the type of functions that ecl_make_cfun accepts." (if (and fname ;; named function ;; no required appears in closure, - (dolist (var (car lambda-list) t) + (dolist (var requireds t) (declare (type var var)) (when (var-ref-ccb var) (return nil))) - (null (second lambda-list)) ;; no optionals, - (null (third lambda-list)) ;; no rest parameter, and - (null (fourth lambda-list))) ;; no keywords. - (setf *tail-recursion-info* (cons *tail-recursion-info* (car lambda-list))) + (null optionals) ;; no optionals, + (null rest) ;; no rest parameter, and + (null key-flag)) ;; no keywords. + (setf *tail-recursion-info* (cons *tail-recursion-info* requireds)) (setf *tail-recursion-info* nil)) ;; check arguments @@ -396,7 +397,7 @@ The function thus belongs to the type of functions that ecl_make_cfun accepts." (when varargs (when requireds (wt-nl "if (ecl_unlikely(narg<" nreq ")) FEwrong_num_arguments_anonym();")) - (unless (or rest keywords allow-other-keys) + (unless (or rest key-flag allow-other-keys) (wt-nl "if (ecl_unlikely(narg>" (+ nreq nopt) ")) FEwrong_num_arguments_anonym();")))) (open-inline-block)) @@ -431,7 +432,7 @@ The function thus belongs to the type of functions that ecl_make_cfun accepts." ;; dont create rest or varargs if not used (when (and rest (< (var-ref rest) 1)) (setq rest nil - varargs (or optionals keywords allow-other-keys))) + varargs (or optionals key-flag allow-other-keys))) ;; Declare &optional variables (do ((opt optionals (cdddr opt))) ((endp opt)) @@ -453,7 +454,7 @@ The function thus belongs to the type of functions that ecl_make_cfun accepts." ((eq closure-type 'LEXICAL) (format nil "lex~D" (1- *level*))) (t "narg")))) - (if (setq simple-varargs (and (not (or rest keywords allow-other-keys)) + (if (setq simple-varargs (and (not (or rest key-flag allow-other-keys)) (<= (+ nreq nopt) si::c-arguments-limit))) (wt-nl "va_list args; va_start(args," (last-variable) @@ -502,8 +503,8 @@ The function thus belongs to the type of functions that ecl_make_cfun accepts." (wt-nl "}")) (wt-nl-close-brace))) - (when (or rest keywords allow-other-keys) - (cond ((not (or keywords allow-other-keys)) + (when (or rest key-flag allow-other-keys) + (cond ((not (or key-flag allow-other-keys)) (wt-nl rest-loc " = cl_grab_rest_args(args);")) (t (cond (keywords From 14d46da1340825902c1e9e22aab2415ed349d76d Mon Sep 17 00:00:00 2001 From: Marius Gerbershagen Date: Fri, 20 Mar 2020 21:42:23 +0100 Subject: [PATCH 3/4] cmp: fix evaluation order bugs in compiler macros --- src/cmp/cmpmap.lsp | 4 ++-- src/cmp/cmpopt-sequence.lsp | 10 ++++++---- 2 files changed, 8 insertions(+), 6 deletions(-) diff --git a/src/cmp/cmpmap.lsp b/src/cmp/cmpmap.lsp index fca1186b2..9a1d71143 100644 --- a/src/cmp/cmpmap.lsp +++ b/src/cmp/cmpmap.lsp @@ -54,8 +54,8 @@ do (let ((var (gensym))) (setf iterators (cons var iterators) for-statements (list* :for var in-or-on arg for-statements)))) - `(loop ,@list-1-form - ,@fun-with + `(loop ,@fun-with + ,@list-1-form ,@for-statements ,do-or-collect (funcall ,function ,@iterators) ,@finally-form)))) diff --git a/src/cmp/cmpopt-sequence.lsp b/src/cmp/cmpopt-sequence.lsp index cbbf34416..7443f3179 100644 --- a/src/cmp/cmpopt-sequence.lsp +++ b/src/cmp/cmpopt-sequence.lsp @@ -210,10 +210,11 @@ (return-from expand-member `(ffi:c-inline (,value ,list) (:object :object) :object "ecl_member(#0,#1)" :one-liner t :side-effects nil))))) - (ext:with-unique-names (%value %sublist %elt) + (ext:with-unique-names (%value %list %sublist %elt) `(let ((,%value ,value) + (,%list ,list) ,@init) - (do-in-list (,%elt ,%sublist ,list) + (do-in-list (,%elt ,%sublist ,%list) (when ,(funcall test-function %value (funcall key-function %elt)) (return ,%sublist))))))) @@ -251,10 +252,11 @@ `(ffi:c-inline (,value ,list) (:object :object) :object "ecl_assqlp(#0,#1)" :one-liner t :side-effects nil))))) (when test-function - (ext:with-unique-names (%value %sublist %elt %car) + (ext:with-unique-names (%value %list %sublist %elt %car) `(let ((,%value ,value) + (,%list ,list) ,@init) - (do-in-list (,%elt ,%sublist ,list) + (do-in-list (,%elt ,%sublist ,%list) (when ,%elt (let ((,%car (cons-car (optional-type-check ,%elt cons)))) (when ,(funcall test-function %value From 91d251a7bab79f3b8e4b4cf0333b4d72b7694e50 Mon Sep 17 00:00:00 2001 From: Marius Gerbershagen Date: Sat, 21 Mar 2020 11:54:40 +0100 Subject: [PATCH 4/4] cmp: correctly handle unused special &rest variables Even when the variable is not used, we still have to do the binding. --- src/cmp/cmplam.lsp | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/src/cmp/cmplam.lsp b/src/cmp/cmplam.lsp index 3777d35a5..29f02ed6f 100644 --- a/src/cmp/cmplam.lsp +++ b/src/cmp/cmplam.lsp @@ -430,7 +430,8 @@ The function thus belongs to the type of functions that ecl_make_cfun accepts." when (unboxed var) do (setf (var-loc var) (wt-decl var))) ;; dont create rest or varargs if not used - (when (and rest (< (var-ref rest) 1)) + (when (and rest (< (var-ref rest) 1) + (not (eq (var-kind rest) 'SPECIAL))) (setq rest nil varargs (or optionals key-flag allow-other-keys))) ;; Declare &optional variables