From b84c480e3bdff366310b6b6d82d44063dc348593 Mon Sep 17 00:00:00 2001 From: Alejandro Zamora Date: Fri, 1 Sep 2023 18:04:11 -0300 Subject: [PATCH] Fix to issue when compiling literal quoted forms that share information, see https://github.com/armedbear/abcl/issues/606 --- src/org/armedbear/lisp/compiler-pass2.lisp | 71 +++++++++++++++++-- test/lisp/abcl/compiler-tests.lisp | 80 +++++++++++++++++++++- 2 files changed, 143 insertions(+), 8 deletions(-) diff --git a/src/org/armedbear/lisp/compiler-pass2.lisp b/src/org/armedbear/lisp/compiler-pass2.lisp index b510b70c2..fe24870b3 100644 --- a/src/org/armedbear/lisp/compiler-pass2.lisp +++ b/src/org/armedbear/lisp/compiler-pass2.lisp @@ -1288,6 +1288,61 @@ of the other types." 4. The function to dispatch serialization to 5. The type of the field to save the serialized result to") +(defun shared-structure-p (object) + "Determines if a literal object shares some structure with previous externalized + objects" + (let ((circularity-hashtable (make-hash-table :test 'eq))) + (labels ((sh-str-helper (obj) + (unless (eq obj 'quote) + (multiple-value-bind (value present-p) + (gethash obj circularity-hashtable) + (declare (ignore value)) + (if present-p + (return-from sh-str-helper nil) + (setf (gethash obj circularity-hashtable) t)))) + (cond + ((atom obj) + (when (assoc obj *externalized-objects* :test #'eq) + (return-from shared-structure-p t))) + ((listp obj) + (when (assoc obj *externalized-objects* :test #'eq) + (return-from shared-structure-p t)) + (progn (sh-str-helper (car obj)) + (sh-str-helper (cdr obj)))) + (t nil)))) + (sh-str-helper object)))) + +(defun quoted-form-p (object) + "Determines if a literal object is a quoted form applied to a list object" + (and + (eq (car object) 'cl:quote) + (listp (second object)))) + + +(defmacro emit-cons2 (&key car (cdr '((emit-push-nil)))) + `(progn + (emit-new +lisp-cons+) + (emit 'dup) + (progn + ,@car) + (progn + ,@cdr) + (emit-invokespecial-init +lisp-cons+ (lisp-object-arg-types 2)))) + + +(defun emit-shared-structure (object field-type cast) + "Emit code for the quoted form literal with shared structure with previous +externalized objects" + (if (eq (car object) 'quote) + (emit-cons2 :car ((compile-form ''quote 'stack nil)) + :cdr ((emit-cons2 + :car ((emit-shared-structure (second object) field-type cast))))) + (let ((existing (assoc object *externalized-objects* :test #'eq))) + (emit-getstatic *this-class* (cdr existing) field-type) + (when cast + (emit-checkcast cast))))) + + (defknown emit-load-externalized-object (t &optional t) string) (defun emit-load-externalized-object (object &optional cast) "Externalizes `object' for use in a FASL. @@ -1304,7 +1359,6 @@ the constructor if `*declare-inline*' is non-nil. ;; of the field it just loaded (to allow casting and what not). ;; The function should still do what it does today: de-serialize the ;; object and storing its value. - (destructuring-bind (type prefix similarity-fn dispatch-fn field-type) (assoc-if #'(lambda (x) @@ -1320,6 +1374,11 @@ the constructor if `*declare-inline*' is non-nil. (emit-checkcast cast)) (return-from emit-load-externalized-object field-type))) + ;; for things like '#1#, ''#1#, '''#1# and so on ... + (when (and (shared-structure-p object) (quoted-form-p object)) + (emit-shared-structure object field-type cast) + (return-from emit-load-externalized-object field-type)) + ;; We need to set up the serialized value (let ((field-name (symbol-name (gensym prefix)))) (declare-field field-name field-type) @@ -5557,18 +5616,18 @@ We need more thought here. (if list-star-p (compile-form (first (last args)) 'stack nil) (progn - (emit-invokespecial-init + (emit-invokespecial-init +lisp-cons+ (lisp-object-arg-types 1)) (pop cons-heads))) ; we've handled one of the args, so remove it (dolist (cons-head cons-heads) (declare (ignore cons-head)) - (emit-invokespecial-init + (emit-invokespecial-init +lisp-cons+ (lisp-object-arg-types 2))) (if list-star-p (progn (apply #'maybe-emit-clear-values args) (emit-move-from-stack target representation)) - (progn + (progn (unless (every 'single-valued-p args) (emit-clear-values)) (emit-move-from-stack target)))) @@ -7434,8 +7493,8 @@ We need more thought here. (defun make-compiler-error-form (form condition) `(lambda ,(cadr form) - (error 'program-error :format-control "Program error while compiling ~a" :format-arguments - (if ,condition + (error 'program-error :format-control "Program error while compiling ~a" :format-arguments + (if ,condition (list (apply 'format nil ,(slot-value condition 'sys::format-control) ',(slot-value condition 'sys::format-arguments))) (list "a form"))))) diff --git a/test/lisp/abcl/compiler-tests.lisp b/test/lisp/abcl/compiler-tests.lisp index a784338e8..a37a988c2 100644 --- a/test/lisp/abcl/compiler-tests.lisp +++ b/test/lisp/abcl/compiler-tests.lisp @@ -446,7 +446,7 @@ ;;; ticket #147 #+abcl -(deftest compiler.1 +(deftest compiler.1 (let ((tmpfile (ext::make-temp-file)) (original-print-case *print-case*) (forms `((in-package :cl-user) @@ -466,7 +466,7 @@ #+abcl (deftest compiler.2 (let ((tmpfile (ext::make-temp-file)) - (line "(defconstant a #.(make-array '(8 256) + (line "(defconstant a #.(make-array '(8 256) :element-type '(unsigned-byte 32) :initial-element 0))")) (with-open-file (s tmpfile :direction :output) (format s "~A" line)) @@ -502,3 +502,79 @@ (compile nil '(lambda (&key args &optional x)))) (typep error 'program-error)) t) + + +;;; ticket #606 Github +#+abcl +(deftest compiler.5a + (let ((tmpfile (ext::make-temp-file)) + (code + "(defun abcl/test/lisp::cp5a () + '(0) + (let ((x #1='(0)) + (y (second '#1#))) + (assert (equal x '(0))) + (assert (equal y '(0))) + (assert (eq x y))))")) + (with-open-file (s tmpfile :direction :output) + (format s "~A" code)) + (load (compile-file tmpfile)) + (delete-file tmpfile) + (prog1 (abcl/test/lisp::cp5a) + (fmakunbound 'abcl/test/lisp::cp5a))) + nil) + +#+abcl +(deftest compiler.5b + (let ((tmpfile (ext::make-temp-file)) + (code + "(defun abcl/test/lisp::cp5b () + '(0) + (let ((x #1='(0 #1#)) + (y (second '#1#))) + (assert (eq x y))))")) + (with-open-file (s tmpfile :direction :output) + (format s "~A" code)) + (load (compile-file tmpfile)) + (delete-file tmpfile) + (prog1 (abcl/test/lisp::cp5b) + (fmakunbound 'abcl/test/lisp::cp5b))) + nil) + +#+abcl +(deftest compiler.5c + (let ((tmpfile (ext::make-temp-file)) + (code + "(defun abcl/test/lisp::cp5c () + '(0) + (let ((x #1='(0)) + (y (second (second ''#1#)))) + (assert (equal x '(0))) + (assert (equal y '(0))) + (assert (eq x y))))")) + (with-open-file (s tmpfile :direction :output) + (format s "~A" code)) + (load (compile-file tmpfile)) + (delete-file tmpfile) + (prog1 (abcl/test/lisp::cp5c) + (fmakunbound 'abcl/test/lisp::cp5c))) + nil) + +#+abcl +(deftest compiler.5d + (let ((tmpfile (ext::make-temp-file)) + (code + "(defun abcl/test/lisp::cp5d () + '(0) + (let ((x #1='(0)) + (y (second (second (second '''#1#))))) + (assert (equal x '(0))) + (assert (equal y '(0))) + (assert (eq x y))))")) + (with-open-file (s tmpfile :direction :output) + (format s "~A" code)) + (load (compile-file tmpfile)) + (delete-file tmpfile) + (prog1 (abcl/test/lisp::cp5d) + (fmakunbound 'abcl/test/lisp::cp5d))) + nil)