Raymond Toy pushed to branch issue-243-weak-pointer-to-static-array at cmucl / cmucl Commits: c65d8078 by Raymond Toy at 2024-01-29T17:32:41+00:00 Fix #271: Update ASDF to version 3.3.7 - - - - - 7e4b96a1 by Raymond Toy at 2024-01-29T17:32:44+00:00 Merge branch 'issue-271-update-asdf-3.3.7' into 'master' Fix #271: Update ASDF to version 3.3.7 See merge request cmucl/cmucl!186 - - - - - 569067e1 by Raymond Toy at 2024-02-14T15:59:07+00:00 Fix #256: loop for var nil works - - - - - f570ce79 by Raymond Toy at 2024-02-14T15:59:10+00:00 Merge branch 'issue-256-loop-var-nil' into 'master' Fix #256: loop for var nil works Closes #256 See merge request cmucl/cmucl!185 - - - - - cda885f5 by Raymond Toy at 2024-02-14T16:22:26+00:00 Fix #272; Move scavenge code for static vectors to its own function - - - - - c8cafc4b by Raymond Toy at 2024-02-14T16:22:28+00:00 Merge branch 'issue-272-add-scav-static-vector-fcn' into 'master' Fix #272; Move scavenge code for static vectors to its own function Closes #272 See merge request cmucl/cmucl!187 - - - - - d6358eaf by Raymond Toy at 2024-02-14T11:44:38-08:00 Update with recent bug fixes Forgot to update this when each bug was fixed. - - - - - daeccf04 by Raymond Toy at 2024-02-14T14:36:46-08:00 Merge branch 'master' into issue-243-weak-pointer-to-static-array - - - - - 44743f61 by Raymond Toy at 2024-02-14T15:59:45-08:00 Implement algorithm suggested by Carl First cut at implementing the algorithm. More work needed. - - - - - 9fe13723 by Raymond Toy at 2024-02-15T07:09:37-08:00 Forgot to break the weak pointers to static vector being freed When we free the static vector, we need to break the weak pointer to the now free space. (Duh!) Update some prints to make it a little clearer what's happening. - - - - - 7f34622e by Raymond Toy at 2024-02-15T07:25:18-08:00 Print debug stuff only if debug_static_array_p is set. - - - - - 8 changed files: - src/code/loop.lisp - src/contrib/asdf/asdf.lisp - src/contrib/asdf/doc/asdf.html - src/contrib/asdf/doc/asdf.info - src/contrib/asdf/doc/asdf.pdf - src/general-info/release-21f.md - src/lisp/gencgc.c - + tests/loop.lisp Changes: ===================================== src/code/loop.lisp ===================================== @@ -1169,7 +1169,10 @@ collected result will be returned as the value of the LOOP." ;; these type symbols. (let ((type-spec (or (gethash z (loop-universe-type-symbols *loop-universe*)) (gethash (symbol-name z) (loop-universe-type-keywords *loop-universe*))))) - (when type-spec + ;; If Z is NIL, we have something like (loop for var nil ...). + ;; In that case, we need to pop the source to skip over the + ;; type, just as if we had (loop for var fixnum ...) + (when (or type-spec (null z)) (loop-pop-source) type-spec))) (t ===================================== src/contrib/asdf/asdf.lisp ===================================== @@ -1,5 +1,5 @@ ;;; -*- mode: Lisp; Base: 10 ; Syntax: ANSI-Common-Lisp ; Package: CL-USER ; buffer-read-only: t; -*- -;;; This is ASDF 3.3.6: Another System Definition Facility. +;;; This is ASDF 3.3.7: Another System Definition Facility. ;;; ;;; Feedback, bug reports, and patches are all welcome: ;;; please mail to <asdf-devel@common-lisp.net>. @@ -1848,7 +1848,7 @@ form suitable for testing with #+." (in-package :uiop/version) (with-upgradability () - (defparameter *uiop-version* "3.3.6") + (defparameter *uiop-version* "3.3.7") (defun unparse-version (version-list) "From a parsed version (a list of natural numbers), compute the version string" @@ -2144,18 +2144,56 @@ use getenvp to return NIL in such a case." (defsetf getenv (x) (val) "Set an environment variable." - (declare (ignorable x val)) - #+allegro `(setf (sys:getenv ,x) ,val) - #+clasp `(ext:setenv ,x ,val) - #+clisp `(system::setenv ,x ,val) - #+clozure `(ccl:setenv ,x ,val) - #+cmucl `(unix:unix-setenv ,x ,val 1) - #+(or ecl clasp) `(ext:setenv ,x ,val) - #+lispworks `(setf (lispworks:environment-variable ,x) ,val) - #+mkcl `(mkcl:setenv ,x ,val) - #+sbcl `(progn (require :sb-posix) (symbol-call :sb-posix :setenv ,x ,val 1)) - #-(or allegro clasp clisp clozure cmucl ecl lispworks mkcl sbcl) - '(not-implemented-error '(setf getenv))) + (declare (ignorable x val)) ; for the not-implemented cases. + (if (constantp val) + (if val + #+allegro `(setf (sys:getenv ,x) ,val) + #+clasp `(ext:setenv ,x ,val) + #+clisp `(system::setenv ,x ,val) + #+clozure `(ccl:setenv ,x ,val) + #+cmucl `(unix:unix-setenv ,x ,val 1) + #+ecl `(ext:setenv ,x ,val) + #+lispworks `(setf (lispworks:environment-variable ,x) ,val) + #+mkcl `(mkcl:setenv ,x ,val) + #+sbcl `(progn (require :sb-posix) (symbol-call :sb-posix :setenv ,x ,val 1)) + #-(or allegro clasp clisp clozure cmucl ecl lispworks mkcl sbcl) + '(not-implemented-error '(setf getenv)) + ;; VAL is NIL, unset the variable + #+allegro `(symbol-call :excl.osi :unsetenv ,x) + ;; #+clasp `(ext:setenv ,x ,val) ; UNSETENV is not supported. + #+clisp `(system::setenv ,x ,val) ; need fix -- no idea if this works. + #+clozure `(ccl:unsetenv ,x) + #+cmucl `(unix:unix-unsetenv ,x) + #+ecl `(ext:setenv ,x ,val) ; Looked at source, don't see UNSETENV + #+lispworks `(setf (lispworks:environment-variable ,x) ,val) ; according to their docs, this should unset the variable + #+mkcl `(mkcl:setenv ,x ,val) ; like other ECL-family implementations, don't see UNSETENV + #+sbcl `(progn (require :sb-posix) (symbol-call :sb-posix :unsetenv ,x)) + #-(or allegro clisp clozure cmucl ecl lispworks mkcl sbcl) + '(not-implemented-error 'unsetenv)) + `(if ,val + #+allegro (setf (sys:getenv ,x) ,val) + #+clasp (ext:setenv ,x ,val) + #+clisp (system::setenv ,x ,val) + #+clozure (ccl:setenv ,x ,val) + #+cmucl (unix:unix-setenv ,x ,val 1) + #+ecl (ext:setenv ,x ,val) + #+lispworks (setf (lispworks:environment-variable ,x) ,val) + #+mkcl (mkcl:setenv ,x ,val) + #+sbcl (progn (require :sb-posix) (symbol-call :sb-posix :setenv ,x ,val 1)) + #-(or allegro clasp clisp clozure cmucl ecl lispworks mkcl sbcl) + '(not-implemented-error '(setf getenv)) + ;; VAL is NIL, unset the variable + #+allegro (symbol-call :excl.osi :unsetenv ,x) + ;; #+clasp (ext:setenv ,x ,val) ; UNSETENV not supported + #+clisp (system::setenv ,x ,val) ; need fix -- no idea if this works. + #+clozure (ccl:unsetenv ,x) + #+cmucl (unix:unix-unsetenv ,x) + #+ecl (ext:setenv ,x ,val) ; Looked at source, don't see UNSETENV + #+lispworks (setf (lispworks:environment-variable ,x) ,val) ; according to their docs, this should unset the variable + #+mkcl (mkcl:setenv ,x ,val) ; like other ECL-family implementations, don't see UNSETENV + #+sbcl (progn (require :sb-posix) (symbol-call :sb-posix :unsetenv ,x)) + #-(or allegro clisp clozure cmucl ecl lispworks mkcl sbcl) + '(not-implemented-error 'unsetenv)))) (defun getenvp (x) "Predicate that is true if the named variable is present in the libc environment, @@ -2240,7 +2278,7 @@ then returning the non-empty string value of the variable" ;; Note if not using International ACL ;; see http://www.franz.com/support/documentation/8.1/doc/operators/excl/ics-target... (excl:ics-target-case (:-ics "8")) - (and (member :smp *features*) "S")) + (and (member :smp *features*) "SBT")) #+armedbear (format nil "~a-fasl~a" s system::*fasl-version*) #+clisp (subseq s 0 (position #\space s)) ; strip build information (date, etc.) @@ -2282,7 +2320,8 @@ suitable for use as a directory name to segregate Lisp FASLs, C dynamic librarie (or (implementation-type) (lisp-implementation-type)) (lisp-version-string) (or (operating-system) (software-type)) - (or (architecture) (machine-type)))))) + (or (architecture) (machine-type)) + #+sbcl (if (featurep :sb-thread) "S" ""))))) ;;;; Other system information @@ -2426,8 +2465,6 @@ the number having BYTES octets (defaulting to 4)." (end-of-file (c) (declare (ignore c)) nil))))) - - ;;;; ------------------------------------------------------------------------- ;;;; Portability layer around Common Lisp pathnames ;; This layer allows for portable manipulation of pathname objects themselves, @@ -4554,7 +4591,7 @@ Upon success, the KEEP form is evaluated and the file is is deleted unless it ev ,@before))) ,@(when after (assert pathnamep) - `((,afterf (,pathname) ,@after)))) + `((,afterf (,pathname) (declare (ignorable ,pathname)) ,@after)))) #-gcl (declare (dynamic-extent ,@(when before `(#',beforef)) ,@(when after `(#',afterf)))) (call-with-temporary-file ,(when before `#',beforef) @@ -4673,7 +4710,7 @@ when the image is restarted, but before the entry point is called.") before the image dump hooks are called and before the image is dumped.") (defvar *image-dump-hook* nil - "Functions to call (in order) when before an image is dumped")) + "Functions to call (in order) before an image is dumped")) (eval-when (#-lispworks :compile-toplevel :load-toplevel :execute) (deftype fatal-condition () @@ -4984,9 +5021,17 @@ or COMPRESSION on SBCL, and APPLICATION-TYPE on SBCL/Windows." #-(or clisp clozure (and cmucl executable) lispworks sbcl scl) (when executable (not-implemented-error 'dump-image "dumping an executable")) - #+allegro + #+allegro ;; revised with help from Franz (progn - (sys:resize-areas :global-gc t :pack-heap t :sift-old-areas t :tenure t) ; :new 5000000 + #+(and allegro-version>= (version>= 11)) + (sys:resize-areas + :old :no-change :old-code :no-change + :global-gc t + :tenure t) + #+(and allegro-version>= (version= 10 1)) + (sys:resize-areas :old 10000000 :global-gc t :pack-heap t :sift-old-areas t :tenure t) + #+(and allegro-version>= (not (version>= 10 1))) + (sys:resize-areas :global-gc t :pack-heap t :sift-old-areas t :tenure t) (excl:dumplisp :name filename :suppress-allegro-cl-banner t)) #+clisp (apply #'ext:saveinitmem filename @@ -5122,7 +5167,8 @@ or COMPRESSION on SBCL, and APPLICATION-TYPE on SBCL/Windows." ;; Variables #:*compile-file-warnings-behaviour* #:*compile-file-failure-behaviour* #:*output-translation-function* - #:*optimization-settings* #:*previous-optimization-settings* + ;; the following dropped because unnecessary. + ;; #:*optimization-settings* #:*previous-optimization-settings* #:*base-build-directory* #:compile-condition #:compile-file-error #:compile-warned-error #:compile-failed-error #:compile-warned-warning #:compile-failed-warning @@ -5132,7 +5178,10 @@ or COMPRESSION on SBCL, and APPLICATION-TYPE on SBCL/Windows." ;; Types #+sbcl #:sb-grovel-unknown-constant-condition ;; Functions & Macros - #:get-optimization-settings #:proclaim-optimization-settings #:with-optimization-settings + ;; the following three removed from UIOP because they have bugs, it's + ;; easier to remove tham than to fix them, and they could never have been + ;; used successfully in the wild. [2023/12/11:rpg] + ;; #:get-optimization-settings #:proclaim-optimization-settings #:with-optimization-settings #:call-with-muffled-compiler-conditions #:with-muffled-compiler-conditions #:call-with-muffled-loader-conditions #:with-muffled-loader-conditions #:reify-simple-sexp #:unreify-simple-sexp @@ -5167,6 +5216,7 @@ what more while the input-file is shortened if possible to ENOUGH-PATHNAME relat This can help you produce more deterministic output for FASLs.")) ;;; Optimization settings +#+ignore (with-upgradability () (defvar *optimization-settings* nil "Optimization settings to be used by PROCLAIM-OPTIMIZATION-SETTINGS") @@ -5224,7 +5274,7 @@ This can help you produce more deterministic output for FASLs.")) (proclaim `(optimize ,@,reset-settings))))) #-(or allegro clasp clisp) `(let ,(loop :for v :in +optimization-variables+ :collect `(,v ,v)) - ,@(when settings `((proclaim `(optimize ,@,settings)))) + ,@(when settings `((proclaim '(optimize ,@settings)))) ,@body))) @@ -5495,7 +5545,16 @@ Simple means made of symbols, numbers, characters, simple-strings, pathnames, co using READ within a WITH-SAFE-IO-SYNTAX, that represents the warnings currently deferred by WITH-COMPILATION-UNIT. One of three functions required for deferred-warnings support in ASDF." #+allegro - (list :functions-defined excl::.functions-defined. + (list :functions-defined + #+(and allegro-version>= (version>= 11)) + (let (functions-defined) + (maphash #'(lambda (k v) + (declare (ignore v)) + (push k functions-defined)) + excl::.functions-defined.) + functions-defined) + #+(and allegro-version>= (not (version>= 11))) + excl::.functions-defined. :functions-called excl::.functions-called.) #+clozure (mapcar 'reify-deferred-warning @@ -5539,10 +5598,18 @@ One of three functions required for deferred-warnings support in ASDF." #+allegro (destructuring-bind (&key functions-defined functions-called) reified-deferred-warnings - (setf excl::.functions-defined. + (setf #+(and allegro-version>= (not (version>= 11))) + excl::.functions-defined. + #+(and allegro-version>= (not (version>= 11))) (append functions-defined excl::.functions-defined.) excl::.functions-called. - (append functions-called excl::.functions-called.))) + (append functions-called excl::.functions-called.)) + #+(and allegro-version>= (version>= 11)) + ;; in ACL >= 11, instead of adding defined functions to a list, + ;; we insert them into a no-values hash-table. + (mapc #'(lambda (fn) + (excl:puthash-key fn excl::.functions-defined.)) + functions-defined)) #+clozure (let ((dw (or ccl::*outstanding-deferred-warnings* (setf ccl::*outstanding-deferred-warnings* (ccl::%defer-warnings t))))) @@ -5605,7 +5672,11 @@ One of three functions required for deferred-warnings support in ASDF." "Reset the set of deferred warnings to be handled at the end of the current WITH-COMPILATION-UNIT. One of three functions required for deferred-warnings support in ASDF." #+allegro - (setf excl::.functions-defined. nil + (setf excl::.functions-defined. + #+(and allegro-version>= (not (version>= 11))) + nil + #+(and allegro-version>= (version>= 11)) + (make-hash-table :test #'equal :values nil) excl::.functions-called. nil) #+clozure (if-let (dw ccl::*outstanding-deferred-warnings*) @@ -7809,7 +7880,8 @@ DEPRECATED." #:*post-upgrade-cleanup-hook* #:cleanup-upgraded-asdf ;; There will be no symbol left behind! #:with-asdf-deprecation - #:intern*) + #:intern* + #:asdf-install-warning) (:import-from :uiop/package #:intern* #:find-symbol*)) (in-package :asdf/upgrade) @@ -7894,7 +7966,7 @@ previously-loaded version of ASDF." ;; "3.4.5.67" would be a development version in the official branch, on top of 3.4.5. ;; "3.4.5.0.8" would be your eighth local modification of official release 3.4.5 ;; "3.4.5.67.8" would be your eighth local modification of development version 3.4.5.67 - (asdf-version "3.3.6") + (asdf-version "3.3.7") (existing-version (asdf-version))) (setf *asdf-version* asdf-version) (when (and existing-version (not (equal asdf-version existing-version))) @@ -7970,6 +8042,19 @@ previously-loaded version of ASDF." (call-functions (reverse *post-upgrade-cleanup-hook*))) t)))) + (define-condition asdf-install-warning (simple-condition warning) + ((format-control + :initarg :format-control) + (format-arguments + :initarg :format-arguments + :initform nil)) + (:documentation "Warning class for issues related to upgrading or loading ASDF.") + (:report (lambda (c s) + (format s "WARNING: ~?" + (slot-value c 'format-control) + (slot-value c 'format-arguments))))) + + (defun upgrade-asdf () "Try to upgrade of ASDF. If a different version was used, return T. We need do that before we operate on anything that may possibly depend on ASDF." @@ -12551,7 +12636,9 @@ into a single file")) #:package-inferred-system #:sysdef-package-inferred-system-search #:package-system ;; backward compatibility only. To be removed. #:register-system-packages - #:*defpackage-forms* #:*package-inferred-systems* #:package-inferred-system-missing-package-error)) + #:*defpackage-forms* #:*package-inferred-systems* + #:package-inferred-system-missing-package-error + #:package-inferred-system-unknown-defpackage-option-error)) (in-package :asdf/package-inferred-system) (with-upgradability () @@ -12602,15 +12689,34 @@ every such file")) trying to define package-inferred-system ~A from file ~A~>") (error-system c) (error-pathname c))))) - (defun package-dependencies (defpackage-form) + (define-condition package-inferred-system-unknown-defpackage-option-error (system-definition-error) + ((system :initarg :system :reader error-system) + (pathname :initarg :pathname :reader error-pathname) + (option :initarg :clause-head :reader error-option) + (arguments :initarg :clause-rest :reader error-arguments)) + (:report (lambda (c s) + (format s (compatfmt "~@<Don't know how to infer package dependencies ~ + for non-standard option ~S ~ + while trying to define package-inferred-system ~A ~ + from file ~A~>") + (cons (error-option c) + (error-arguments c)) + (error-system c) + (error-pathname c))))) + + (defun package-dependencies (defpackage-form &optional system pathname) "Return a list of packages depended on by the package defined in DEFPACKAGE-FORM. A package is depended upon if -the DEFPACKAGE-FORM uses it or imports a symbol from it." +the DEFPACKAGE-FORM uses it or imports a symbol from it. + +SYSTEM should be the name of the system being defined, and +PATHNAME should be the file which contains the DEFPACKAGE-FORM. +These will be used to report errors when encountering an unknown defpackage argument." (assert (defpackage-form-p defpackage-form)) (remove-duplicates (while-collecting (dep) (loop :for (option . arguments) :in (cddr defpackage-form) :do - (ecase option + (case option ((:use :mix :reexport :use-reexport :mix-reexport) (dolist (p arguments) (dep (string p)))) ((:import-from :shadowing-import-from) @@ -12619,7 +12725,37 @@ the DEFPACKAGE-FORM uses it or imports a symbol from it." ((:local-nicknames) (loop :for (nil actual-package-name) :in arguments :do (dep (string actual-package-name)))) - ((:nicknames :documentation :shadow :export :intern :unintern :recycle))))) + ((:nicknames :documentation :shadow :export :intern :unintern :recycle)) + + ;;; SBCL extensions to defpackage relating to package locks. + ;; See https://www.sbcl.org/manual/#Implementation-Packages . + #+(or sbcl ecl) ;; MKCL too? + ((:lock) + ;; A :LOCK clause introduces no dependencies. + nil) + #+sbcl + ((:implement) + ;; A :IMPLEMENT clause introduces dependencies on the listed packages, + ;; as it's not meaningful to :IMPLEMENT a package which hasn't yet been defined. + (dolist (p arguments) (dep (string p)))) + + #+lispworks + ((:add-use-defaults) nil) + + #+allegro + ((:implementation-packages :alternate-name :flat) nil) + + ;; When encountering an unknown OPTION, signal a continuable error. + ;; We cannot in general know whether the unknown clause should introduce any dependencies, + ;; so we cannot do anything other than signal an error here, + ;; but users may know that certain extensions do not introduce dependencies, + ;; and may wish to manually continue building. + (otherwise (cerror "Treat the unknown option as introducing no package dependencies" + 'package-inferred-system-unknown-defpackage-option-error + :system system + :pathname pathname + :option option + :arguments arguments))))) :from-end t :test 'equal)) (defun package-designator-name (package) @@ -13974,6 +14110,13 @@ system or its dependencies if it has already been loaded." (when (boundp 'excl:*warn-on-nested-reader-conditionals*) (setf excl:*warn-on-nested-reader-conditionals* uiop/common-lisp::*acl-warn-save*)) + #+(and allegro allegro-v10.1) ;; check for patch needed for upgradeability + (unless (assoc "ma040" (cdr (assoc :lisp sys:*patches*)) :test 'equal) + (warn 'asdf-install-warning + :format-control "On Allegro Common Lisp 10.1, patch pma040 is ~ +needed for correct ASDF upgrading. Please update your Allegro image ~ +using (SYS:UPDATE-ALLEGRO).")) + ;; Advertise the features we provide. (dolist (f '(:asdf :asdf2 :asdf3 :asdf3.1 :asdf3.2 :asdf3.3)) (pushnew f *features*)) ===================================== src/contrib/asdf/doc/asdf.html ===================================== The diff for this file was not included because it is too large. ===================================== src/contrib/asdf/doc/asdf.info ===================================== The diff for this file was not included because it is too large. ===================================== src/contrib/asdf/doc/asdf.pdf ===================================== Binary files a/src/contrib/asdf/doc/asdf.pdf and b/src/contrib/asdf/doc/asdf.pdf differ ===================================== src/general-info/release-21f.md ===================================== @@ -23,6 +23,7 @@ public domain. * Add support for Gray streams implementation of file-length via `ext:stream-file-length` generic function. * Changes: + * Update to ASDF 3.3.7 * ANSI compliance fixes: * Bug fixes: * Gitlab tickets: @@ -38,8 +39,11 @@ public domain. * ~~#249~~ Replace LEA instruction with simpler shorter instructions in arithmetic vops for x86 * ~~#253~~ Block-compile list-to-hashtable and callers * ~~#258~~ Remove `get-page-size` from linux-os.lisp + * ~~#256~~ loop for var nil works * ~~#269~~ Add function to get user's home directory * ~~#266~~ Support "~user" in namestrings + * ~~#271~~ Update ASDF to 3.3.7 + * ~~#272~~ Move scavenge code for static vectors to its own function * Other changes: * Improvements to the PCL implementation of CLOS: * Changes to building procedure: ===================================== src/lisp/gencgc.c ===================================== @@ -2698,6 +2698,43 @@ maybe_static_array_p(lispobj header) return result; } +static int +scav_static_vector(lispobj object) +{ + lispobj *ptr = (lispobj *) PTR(object); + lispobj header = *ptr; + + if (debug_static_array_p) { + fprintf(stderr, "Not in Lisp spaces: object = %p, ptr = %p\n", + (void*)object, ptr); + fprintf(stderr, " Header value = 0x%lx\n", (unsigned long) header); + } + + if (maybe_static_array_p(header)) { + int static_p; + + if (debug_static_array_p) { + fprintf(stderr, "Possible static vector at %p. header = 0x%lx\n", + ptr, (unsigned long) header); + } + + static_p = (HeaderValue(header) & 1) == 1; + if (static_p) { + /* + * We have a static vector. Mark it as + * reachable by setting the MSB of the header. + */ + *ptr = header | 0x80000000; + if (debug_static_array_p) { + fprintf(stderr, "Scavenged static vector @%p, header = 0x%lx\n", + ptr, (unsigned long) header); + } + } + } + + return 1; +} +  /* Scavenging */ @@ -2756,41 +2793,7 @@ scavenge(void *start_obj, long nwords) || other_space_p(object)) { words_scavenged = 1; } else { - lispobj *ptr = (lispobj *) PTR(object); - words_scavenged = 1; - if (debug_static_array_p) { - fprintf(stderr, "Not in Lisp spaces: object = %p, ptr = %p\n", - (void*)object, ptr); - } - - if (1) { - lispobj header = *ptr; - if (debug_static_array_p) { - fprintf(stderr, " Header value = 0x%lx\n", (unsigned long) header); - } - - if (maybe_static_array_p(header)) { - int static_p; - - if (debug_static_array_p) { - fprintf(stderr, "Possible static vector at %p. header = 0x%lx\n", - ptr, (unsigned long) header); - } - - static_p = (HeaderValue(header) & 1) == 1; - if (static_p) { - /* - * We have a static vector. Mark it as - * reachable by setting the MSB of the header. - */ - *ptr = header | 0x80000000; - if (debug_static_array_p) { - fprintf(stderr, "Scavenged static vector @%p, header = 0x%lx\n", - ptr, (unsigned long) header); - } - } - } - } + words_scavenged = scav_static_vector(object); } } else if ((object & 3) == 0) words_scavenged = 1; @@ -5394,6 +5397,7 @@ size_weak_pointer(lispobj * where) } +#if 0 static void update_static_vector_list(lispobj value, lispobj* vectors_to_free, int* num_static_vectors) { @@ -5421,26 +5425,33 @@ update_static_vector_list(lispobj value, lispobj* vectors_to_free, int* num_stat ++*num_static_vectors; } } +#endif void scan_weak_pointers(void) { struct weak_pointer *wp; - lispobj* vectors_to_free = NULL; + struct weak_pointer **clearable_list; int num_weak_pointers = 0; int num_static_vectors = 0; int n; /* * Count the number of weak pointers so we can allocate enough - * space for vectors_to_free. + * space for clearable_list. */ + + if (debug_static_array_p) { + printf("Phase 0\n"); + } for (wp = weak_pointers; wp; wp = wp->next) { num_weak_pointers++; } - printf("weak pointer count = %d\n", num_weak_pointers); + if (debug_static_array_p) { + printf("weak pointer count = %d\n", num_weak_pointers); + } /* Nothing to do if there are no weak pointers */ if (num_weak_pointers == 0) { @@ -5451,14 +5462,16 @@ scan_weak_pointers(void) * Allocate enough space to hold all weak pointers in case they * all point to static vectors. */ - vectors_to_free = (lispobj*) malloc(num_weak_pointers * sizeof(lispobj)); - gc_assert(vectors_to_free); - - printf("vectors_to_free = %p\n", vectors_to_free); + clearable_list = (struct weak_pointer **) malloc(num_weak_pointers * sizeof(struct weak_pointer *)); + gc_assert(clearable_list); /* * Now process the weak pointers. */ + if (debug_static_array_p) { + printf("Phase 1\n"); + } + for (wp = weak_pointers; wp; wp = wp->next) { lispobj value = wp->value; lispobj *first_pointer = (lispobj *) PTR(value); @@ -5476,22 +5489,24 @@ scan_weak_pointers(void) /* The value may be a static vector */ lispobj *header = (lispobj *) PTR(value); - printf("value %p, header = %0lx\n", (lispobj*) value, *header); + if (debug_static_array_p) { + printf("wp %p: value %p, header = 0x%08lx\n", + wp, (lispobj*) value, *header); + } if (maybe_static_array_p(*header)) { /* * A header value of 1 means we have a static * vector with the in-use bit cleared, so we can - * collect the vector. + * add this weak pointer to the clearable list. */ if (HeaderValue(*header) == 1) { - update_static_vector_list(value, vectors_to_free, &num_static_vectors); - - /* - * Now we can break the weak pointer to the static vector. - */ - wp->value = NIL; - wp->broken = T; + if (debug_static_array_p) { + printf(" clearable_list[%d] = %p\n", num_static_vectors, wp); + } + + clearable_list[num_static_vectors] = wp; + ++num_static_vectors; } } } @@ -5499,17 +5514,75 @@ scan_weak_pointers(void) } /* - * Free up any unreferenced static vectors now + * Traverse the clearable list. If the weak pointer points to an + * unmarked static vector, mark it. If it points to a marked + * static vector, then we know it shares a referent with another + * weak pointer. Break this weak pointer and remove it from the + * clearable list by setting it to NIL. + */ + if (debug_static_array_p) { + printf("Phase 2: %d pointers\n", num_static_vectors); + } + + for (n = 0; n < num_static_vectors; ++n) { + struct weak_pointer *wp = clearable_list[n]; + lispobj *header = (lispobj *) PTR(wp->value); + + if (debug_static_array_p) { + printf("%2d: wp = %p, header = 0x%08lx\n", n, wp, *header); + } + + if (HeaderValue(*header) == 1) { + /* + * If the header value is 1, we have an unmarked static + * vector. Mark it now. + */ + if (debug_static_array_p) { + printf(" Mark vector\n"); + } + + *header |= 0x80000000; + } else { + /* + * We have a marked static vector. Break this weak + * pointer and remove it from the list by setting it to + * NIL. + */ + if (debug_static_array_p) { + printf(" Break weak pointer %p\n", wp); + } + + wp->value = NIL; + wp->broken = T; + clearable_list[n] = NULL; + } + } + + /* + * Traverse the clearable list and free the static vector, + * skipping over any NIL values. */ - printf("%d static vectors to be freed\n", num_static_vectors); + + if (debug_static_array_p) { + printf("Phase 3: Free static vectors\n"); + } for (n = 0; n < num_static_vectors; ++n) { - lispobj *header = (lispobj *) PTR(vectors_to_free[n]); - printf("free %p: %p\n", (void*) vectors_to_free[n], header); - free(header); + struct weak_pointer *wp = clearable_list[n]; + if (wp != NULL) { + lispobj *static_array = (lispobj *) PTR(wp->value); + + if (debug_static_array_p) { + printf("%2d: free wp %p: %p\n", n, (void*) wp, static_array); + } + + free(static_array); + wp->value = NIL; + wp->broken = T; + } } - free(vectors_to_free); + free(clearable_list); }  ===================================== tests/loop.lisp ===================================== @@ -0,0 +1,14 @@ +;;; Tests from gitlab issues + +(defpackage :loop-tests + (:use :cl :lisp-unit)) + +(in-package "LOOP-TESTS") + +(define-test loop-var-nil + (:tag :issues) + ;; Just verify that (loop for var nil ...) works. Previously it + ;; signaled an error. See Gitlab issue #256. + (assert-equal '(1 2) + (loop for var nil from 1 to 2 collect var))) + View it on GitLab: https://gitlab.common-lisp.net/cmucl/cmucl/-/compare/b6faa24ed282c902b9f9253... -- View it on GitLab: https://gitlab.common-lisp.net/cmucl/cmucl/-/compare/b6faa24ed282c902b9f9253... You're receiving this email because of your account on gitlab.common-lisp.net.