From 3b45a7b66afe95080562d266dd447b1286abece0 Mon Sep 17 00:00:00 2001 From: William Harold Newman Date: Mon, 20 Aug 2001 16:54:04 +0000 Subject: [PATCH] 0.pre7.14.flaky4.1: (This version builds under older versions of SBCL, but can't build under itself, dying somewhere in defun-load-or-cload-xcompiler.lisp.) fixed (FUNCALL (COMPILE NIL (LAMBDA (X) (+ X 2))) 3) problem under new #!-SB-INTERPRETER implementation of EVAL.. ..should usually be quoted, (COMPILE NIL '(LAMBDA ..)) ..When it's not quoted, so that under the new EVAL the LAMBDA will be a (byte-)compiled function, COMPILE shouldn't fail, it should pass the compiled function through. deleted unused *BACKEND-INFO-ENVIRONMENT* --- package-data-list.lisp-expr | 1 - src/cold/shared.lisp | 8 +- src/compiler/backend.lisp | 4 - src/compiler/knownfun.lisp | 10 +- src/compiler/main.lisp | 8 +- src/compiler/target-main.lisp | 50 ++++++---- tests/time.pure.lisp | 28 +++--- tests/type.impure.lisp | 211 +++++++++++++++++++++-------------------- version.lisp-expr | 2 +- 9 files changed, 170 insertions(+), 152 deletions(-) diff --git a/package-data-list.lisp-expr b/package-data-list.lisp-expr index 4c5891c..3db1afc 100644 --- a/package-data-list.lisp-expr +++ b/package-data-list.lisp-expr @@ -152,7 +152,6 @@ "%UNWIND-PROTECT-BREAKUP" "*BACKEND-BYTE-ORDER*" "*BACKEND-DISASSEM-PARAMS*" - "*BACKEND-INFO-ENVIRONMENT*" "*BACKEND-INSTRUCTION-FLAVORS*" "*BACKEND-INSTRUCTION-FORMATS*" "*BACKEND-INTERNAL-ERRORS*" "*BACKEND-PAGE-SIZE*" "*BACKEND-REGISTER-SAVE-PENALTY*" diff --git a/src/cold/shared.lisp b/src/cold/shared.lisp index 8fe5a54..7523ab3 100644 --- a/src/cold/shared.lisp +++ b/src/cold/shared.lisp @@ -95,12 +95,12 @@ ;;; COMPILE-STEM function above. -- WHN 19990321 (defun rename-file-a-la-unix (x y) (rename-file x - ;; (Note that the TRUENAME expression here is lifted from an - ;; example in the ANSI spec for TRUENAME.) + ;; (Note that the TRUENAME expression here is lifted + ;; from an example in the ANSI spec for TRUENAME.) (with-open-file (stream y :direction :output) (close stream) - ;; From the ANSI spec: "In this case, the file is closed - ;; when the truename is tried, so the truename + ;; From the ANSI spec: "In this case, the file is + ;; closed when the truename is tried, so the truename ;; information is reliable." (truename stream)))) (compile 'rename-file-a-la-unix) diff --git a/src/compiler/backend.lisp b/src/compiler/backend.lisp index 6c0c529..280ec4a 100644 --- a/src/compiler/backend.lisp +++ b/src/compiler/backend.lisp @@ -115,10 +115,6 @@ (defvar *backend-parsed-vops* (make-hash-table :test 'eq)) (declaim (type hash-table *backend-parsed-vops*)) -;;; the backend-specific aspects of the info environment -(defvar *backend-info-environment* nil) -(declaim (type list *backend-info-environment*)) - ;;; support for the assembler (defvar *backend-instruction-formats* (make-hash-table :test 'eq)) (defvar *backend-instruction-flavors* (make-hash-table :test 'equal)) diff --git a/src/compiler/knownfun.lisp b/src/compiler/knownfun.lisp index 84799f1..3b38e95 100644 --- a/src/compiler/knownfun.lisp +++ b/src/compiler/knownfun.lisp @@ -169,7 +169,7 @@ (info (make-function-info :attributes attributes :derive-type derive-type :optimizer optimizer)) - (target-env (or *backend-info-environment* *info-environment*))) + (target-env *info-environment*)) (dolist (name names) (let ((old-function-info (info :function :info name))) (when old-function-info @@ -198,8 +198,12 @@ ;;; through here. (declaim (ftype (function (t) function-info) function-info-or-lose)) (defun function-info-or-lose (name) - (let ((*info-environment* (or *backend-info-environment* - *info-environment*))) + (let (;; FIXME: Do we need this rebinding here? It's a literal + ;; translation of the old CMU CL rebinding to + ;; (OR *BACKEND-INFO-ENVIRONMENT* *INFO-ENVIRONMENT*), + ;; and it's not obvious whether the rebinding to itself is + ;; needed that SBCL doesn't need *BACKEND-INFO-ENVIRONMENT*. + (*info-environment* *info-environment*)) (let ((old (info :function :info name))) (unless old (error "~S is not a known function." name)) (setf (info :function :info name) (copy-function-info old))))) diff --git a/src/compiler/main.lisp b/src/compiler/main.lisp index d4a2308..dc21410 100644 --- a/src/compiler/main.lisp +++ b/src/compiler/main.lisp @@ -1261,8 +1261,12 @@ (*last-format-string* nil) (*last-format-args* nil) (*last-message-count* 0) - (*info-environment* (or *backend-info-environment* - *info-environment*)) + ;; FIXME: Do we need this rebinding here? It's a literal + ;; translation of the old CMU CL rebinding to + ;; (OR *BACKEND-INFO-ENVIRONMENT* *INFO-ENVIRONMENT*), + ;; and it's not obvious whether the rebinding to itself is + ;; needed that SBCL doesn't need *BACKEND-INFO-ENVIRONMENT*. + (*info-environment* *info-environment*) (*gensym-counter* 0)) (handler-case (with-compilation-values diff --git a/src/compiler/target-main.lisp b/src/compiler/target-main.lisp index 8159755..d29ce80 100644 --- a/src/compiler/target-main.lisp +++ b/src/compiler/target-main.lisp @@ -13,7 +13,7 @@ (in-package "SB!C") -;;;; COMPILE and UNCOMPILE +;;;; CL:COMPILE (defun get-lambda-to-compile (definition) (if (consp definition) @@ -43,16 +43,16 @@ (when old (substitute-leaf fun old))) name))) -(defun compile (name &optional (definition (fdefinition name))) - #!+sb-doc - "Compiles the function whose name is Name. If Definition is supplied, - it should be a lambda expression that is compiled and then placed in the - function cell of Name. If Name is Nil, the compiled code object is - returned." +;;; Handle the nontrivial case of CL:COMPILE. +(defun actually-compile (name definition) (with-compilation-values (sb!xc:with-compilation-unit () - (let* ((*info-environment* (or *backend-info-environment* - *info-environment*)) + (let* (;; FIXME: Do we need this rebinding here? It's a literal + ;; translation of the old CMU CL rebinding to + ;; (OR *BACKEND-INFO-ENVIRONMENT* *INFO-ENVIRONMENT*), + ;; and it's not obvious whether the rebinding to itself is + ;; needed that SBCL doesn't need *BACKEND-INFO-ENVIRONMENT*. + (*info-environment* *info-environment*) (*lexenv* (make-null-lexenv)) (form `#',(get-lambda-to-compile definition)) (*source-info* (make-lisp-source-info form)) @@ -63,7 +63,7 @@ #'(lambda () (compiler-mumble "~2&fatal error, aborting compilation~%") - (return-from compile (values nil t nil)))) + (return-from actually-compile (values nil t nil)))) (*current-path* nil) (*last-source-context* nil) (*last-original-source* nil) @@ -97,9 +97,27 @@ (dolist (component *all-components*) (compile-component component)))) - (let* ((res1 (core-call-top-level-lambda lambda *compile-object*)) - (result (or name res1))) - (fix-core-source-info *source-info* *compile-object* res1) - (when name - (setf (fdefinition name) res1)) - result)))))) + (let ((compiled-fun (core-call-top-level-lambda lambda + *compile-object*))) + (fix-core-source-info *source-info* *compile-object* compiled-fun) + compiled-fun)))))) + +(defun compile (name &optional (definition (fdefinition name))) + #!+sb-doc + "Coerce DEFINITION (by default, the function whose name is NAME) + to a compiled function, returning (VALUES THING WARNINGS-P FAILURE-P), + where if NAME is NIL, THING is the result of compilation, and + otherwise THING is NAME. When NAME is not NIL, the compiled function + is also set into (FDEFINITION NAME)." + ;;(format t "~&/in COMPILE NAME=~S DEFINITION=~S" name definition) ; REMOVEME + (multiple-value-bind (compiled-definition warnings-p failure-p) + (if (compiled-function-p definition) + (values definition nil nil) + (actually-compile name definition)) + ;;(format t "~&/COMPILED-DEFINITION=~S~%" compiled-definition) ; REMOVEME + (cond (name + (unless failure-p + (setf (fdefinition name) compiled-definition)) + (values name warnings-p failure-p)) + (t + (values compiled-definition warnings-p failure-p))))) diff --git a/tests/time.pure.lisp b/tests/time.pure.lisp index df19ec0..797b465 100644 --- a/tests/time.pure.lisp +++ b/tests/time.pure.lisp @@ -12,23 +12,19 @@ (in-package "CL-USER") ;;; Test for monotonicity of GET-INTERNAL-RUN-TIME. -#+nil ; FIXME: This test can't work as long as - ; (FUNCALL (COMPILE NIL (LAMBDA (X) (+ X 12))) 44) - ; fails with - ; # was defined in a non-null environment. (funcall (compile nil - (lambda (n-seconds) - (declare (type fixnum n-seconds)) - (let* ((n-internal-time-units - (* n-seconds - internal-time-units-per-second)) - (time0 (get-internal-run-time)) - (time1 (+ time0 n-internal-time-units))) - (loop - (let ((time (get-internal-run-time))) - (assert (>= time time0)) - (when (>= time time1) - (return))))))) + '(lambda (n-seconds) + (declare (type fixnum n-seconds)) + (let* ((n-internal-time-units + (* n-seconds + internal-time-units-per-second)) + (time0 (get-internal-run-time)) + (time1 (+ time0 n-internal-time-units))) + (loop + (let ((time (get-internal-run-time))) + (assert (>= time time0)) + (when (>= time time1) + (return))))))) 3) (locally diff --git a/tests/type.impure.lisp b/tests/type.impure.lisp index 733f60f..effe4a0 100644 --- a/tests/type.impure.lisp +++ b/tests/type.impure.lisp @@ -137,111 +137,112 @@ (define-condition condition-foo3 (condition-foo2) ()) (define-condition condition-foo4 (condition-foo3) ()) -(format t "~&/before DEFUN TEST-INLINE-TYPE-TESTS~%") - -(fmakunbound 'test-inline-type-tests) -(defun test-inline-type-tests () - ;; structure type tests - (assert (typep (make-structure-foo3) 'structure-foo2)) - (assert (not (typep (make-structure-foo1) 'structure-foo4))) - (assert (null (ignore-errors - (setf (structure-foo2-x (make-structure-foo1)) 11)))) - - ;; structure-class tests - (assert (typep (make-instance 'structure-class-foo3) - 'structure-class-foo2)) - (assert (not (typep (make-instance 'structure-class-foo1) - 'structure-class-foo4))) - (assert (null (ignore-errors - (setf (slot-value (make-instance 'structure-class-foo1) 'x) - 11)))) - - ;; standard-class tests - (assert (typep (make-instance 'standard-class-foo3) - 'standard-class-foo2)) - (assert (not (typep (make-instance 'standard-class-foo1) - 'standard-class-foo4))) - (assert (null (ignore-errors - (setf (slot-value (make-instance 'standard-class-foo1) 'x) - 11)))) - - ;; condition tests - (assert (typep (make-condition 'condition-foo3) - 'condition-foo2)) - (assert (not (typep (make-condition 'condition-foo1) - 'condition-foo4))) - (assert (null (ignore-errors - (setf (slot-value (make-condition 'condition-foo1) 'x) - 11)))) - (assert (subtypep 'error 't)) - (assert (subtypep 'simple-condition 'condition)) - (assert (subtypep 'simple-error 'simple-condition)) - (assert (subtypep 'simple-error 'error)) - (assert (not (subtypep 'condition 'simple-condition))) - (assert (not (subtypep 'error 'simple-error))) - (assert (eq (car (sb-kernel:class-direct-superclasses (find-class - 'simple-condition))) - (find-class 'condition))) - - (assert (eq (car (sb-pcl:class-direct-superclasses (sb-pcl:find-class - 'simple-condition))) - (sb-pcl:find-class 'condition))) - (assert (null (set-difference - (sb-pcl:class-direct-subclasses (sb-pcl:find-class - 'simple-condition)) - (mapcar #'sb-pcl:find-class '(simple-type-error simple-error - sb-int:simple-style-warning))))) - - ;; precedence lists - (assert (equal (sb-pcl:class-precedence-list - (sb-pcl:find-class 'simple-condition)) - (mapcar #'sb-pcl:find-class '(simple-condition condition - sb-kernel:instance t)))) - - ;; stream classes - (assert (null (sb-kernel:class-direct-superclasses (find-class - 'fundamental-stream)))) - (assert (equal (sb-pcl:class-direct-superclasses (sb-pcl:find-class - 'fundamental-stream)) - (mapcar #'sb-pcl:find-class '(standard-object stream)))) - (assert (null (set-difference - (sb-pcl:class-direct-subclasses (sb-pcl:find-class - 'fundamental-stream)) - (mapcar #'sb-pcl:find-class '(fundamental-binary-stream - fundamental-character-stream - fundamental-output-stream - fundamental-input-stream))))) - (assert (equal (sb-pcl:class-precedence-list (sb-pcl:find-class - 'fundamental-stream)) - (mapcar #'sb-pcl:find-class '(fundamental-stream - standard-object - sb-pcl::std-object - sb-pcl::slot-object - stream - sb-kernel:instance - t)))) - (assert (equal (sb-pcl:class-precedence-list (sb-pcl:find-class - 'fundamental-stream)) - (mapcar #'sb-pcl:find-class '(fundamental-stream - standard-object - sb-pcl::std-object - sb-pcl::slot-object stream - sb-kernel:instance t)))) - (assert (subtypep (find-class 'stream) (find-class t))) - (assert (subtypep (find-class 'fundamental-stream) 'stream)) - (assert (not (subtypep 'stream 'fundamental-stream)))) - -(format t "~&/done with DEFUN TEST-INLINE-TYPE-TESTS~%") - -;;; inline-type tests: -;;; Test the interpreted version. -(test-inline-type-tests) -(format t "~&/done with interpreted (TEST-INLINE-TYPE-TESTS)~%") -;;; Test the compiled version. -#| ; FIXME: fails 'cause FUNCALL of COMPILEd function broken ca. 0.pre7.15 -(compile nil #'test-inline-type-tests) -(test-inline-type-tests) -|# +;;; inline type tests +(format t "~&/setting up *TESTS-OF-INLINE-TYPE-TESTS*~%") +(defparameter *tests-of-inline-type-tests* + '(progn + + ;; structure type tests + (assert (typep (make-structure-foo3) 'structure-foo2)) + (assert (not (typep (make-structure-foo1) 'structure-foo4))) + (assert (null (ignore-errors + (setf (structure-foo2-x (make-structure-foo1)) 11)))) + + ;; structure-class tests + (assert (typep (make-instance 'structure-class-foo3) + 'structure-class-foo2)) + (assert (not (typep (make-instance 'structure-class-foo1) + 'structure-class-foo4))) + (assert (null (ignore-errors + (setf (slot-value (make-instance 'structure-class-foo1) + 'x) + 11)))) + + ;; standard-class tests + (assert (typep (make-instance 'standard-class-foo3) + 'standard-class-foo2)) + (assert (not (typep (make-instance 'standard-class-foo1) + 'standard-class-foo4))) + (assert (null (ignore-errors + (setf (slot-value (make-instance 'standard-class-foo1) 'x) + 11)))) + + ;; condition tests + (assert (typep (make-condition 'condition-foo3) + 'condition-foo2)) + (assert (not (typep (make-condition 'condition-foo1) + 'condition-foo4))) + (assert (null (ignore-errors + (setf (slot-value (make-condition 'condition-foo1) 'x) + 11)))) + (assert (subtypep 'error 't)) + (assert (subtypep 'simple-condition 'condition)) + (assert (subtypep 'simple-error 'simple-condition)) + (assert (subtypep 'simple-error 'error)) + (assert (not (subtypep 'condition 'simple-condition))) + (assert (not (subtypep 'error 'simple-error))) + (assert (eq (car (sb-kernel:class-direct-superclasses + (find-class 'simple-condition))) + (find-class 'condition))) + + (assert (eq (car (sb-pcl:class-direct-superclasses (sb-pcl:find-class + 'simple-condition))) + (sb-pcl:find-class 'condition))) + (assert (null (set-difference + (sb-pcl:class-direct-subclasses (sb-pcl:find-class + 'simple-condition)) + (mapcar #'sb-pcl:find-class + '(simple-type-error simple-error + sb-int:simple-style-warning))))) + + ;; precedence lists + (assert (equal (sb-pcl:class-precedence-list + (sb-pcl:find-class 'simple-condition)) + (mapcar #'sb-pcl:find-class '(simple-condition + condition + sb-kernel:instance + t)))) + + ;; stream classes + (assert (null (sb-kernel:class-direct-superclasses + (find-class 'fundamental-stream)))) + (assert (equal (sb-pcl:class-direct-superclasses (sb-pcl:find-class + 'fundamental-stream)) + (mapcar #'sb-pcl:find-class '(standard-object stream)))) + (assert (null (set-difference + (sb-pcl:class-direct-subclasses (sb-pcl:find-class + 'fundamental-stream)) + (mapcar #'sb-pcl:find-class '(fundamental-binary-stream + fundamental-character-stream + fundamental-output-stream + fundamental-input-stream))))) + (assert (equal (sb-pcl:class-precedence-list (sb-pcl:find-class + 'fundamental-stream)) + (mapcar #'sb-pcl:find-class '(fundamental-stream + standard-object + sb-pcl::std-object + sb-pcl::slot-object + stream + sb-kernel:instance + t)))) + (assert (equal (sb-pcl:class-precedence-list (sb-pcl:find-class + 'fundamental-stream)) + (mapcar #'sb-pcl:find-class '(fundamental-stream + standard-object + sb-pcl::std-object + sb-pcl::slot-object stream + sb-kernel:instance t)))) + (assert (subtypep (find-class 'stream) (find-class t))) + (assert (subtypep (find-class 'fundamental-stream) 'stream)) + (assert (not (subtypep 'stream 'fundamental-stream))))) +;;; Test under the interpreter. +(eval *tests-of-inline-type-tests*) +(format t "~&/done with interpreted *TESTS-OF-INLINE-TYPE-TESTS*~%") +;;; Test under the compiler. +(defun tests-of-inline-type-tests () + #.*tests-of-inline-type-tests*) +(tests-of-inline-type-tests) +(format t "~&/done with compiled (TESTS-OF-INLINE-TYPE-TESTS)~%") ;;; success (quit :unix-status 104) diff --git a/version.lisp-expr b/version.lisp-expr index 6b2ee08..a3deaef 100644 --- a/version.lisp-expr +++ b/version.lisp-expr @@ -16,4 +16,4 @@ ;;; four numeric fields, is used for versions which aren't released ;;; but correspond only to CVS tags or snapshots. -"0.pre7.14.flaky4" +"0.pre7.14.flaky4.1" -- 1.7.10.4