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

Merge branch 'minor-compiler-fixes' into 'develop'

Browse source 
Fix some minor compiler bugs

Closes #545

See merge request embeddable-common-lisp/ecl!191
This commit is contained in:
Daniel Kochmański 2020-03-26 12:41:06 +00:00
commit 4c7658a6fe
5 changed files with 47 additions and 19 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

3
src/cmp/cmpflet.lsp
View file

@ -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)

26
src/cmp/cmplam.lsp
View file

@ -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))
@ -429,9 +430,10 @@ 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 keywords allow-other-keys)))
varargs (or optionals key-flag allow-other-keys)))
;; Declare &optional variables
(do ((opt optionals (cdddr opt)))
((endp opt))
@ -453,7 +455,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 +504,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

4
src/cmp/cmpmap.lsp
View file

@ -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))))

10
src/cmp/cmpopt-sequence.lsp
View file

@ -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

23
src/tests/normal-tests/compiler.lsp
View file

@ -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)))))