From: Nikodemus Siivola Date: Wed, 30 Jul 2008 13:44:55 +0000 (+0000) Subject: 1.0.19.1: DERIVE-TYPE optimizer for %%PRIMITIVE X-Git-Url: http://repo.macrolet.net/gitweb/?a=commitdiff_plain;h=367316f5f21281204393853910848fea7fb9a6ab;p=sbcl.git 1.0.19.1: DERIVE-TYPE optimizer for %%PRIMITIVE * Fixes #427: vintage TRULY-THE annotated the CALL early enough that the IR2 conversion of the %PRIMITIVE got the right primitive types. Now that TRULY-THE is a regular cast, an optimizer is needed to annotate the call. * Refactor FIND-TEMPLATE-RESULTS a bit. * Get rid of now-pointless TRULY-THE wrappers around several %PRIMITIVE calls. * Test-case. --- diff --git a/BUGS b/BUGS index 0902dfd..0dbe1e1 100644 --- a/BUGS +++ b/BUGS @@ -1907,15 +1907,6 @@ generally try to check returns in safe code, so we should here too.) call for functions already inline converted there, but he is not sure if this has adverse effects elsewhere. -427: ANY-REG not good for primitive type T - - ...which is true, of course, but the following should not complain - about it (on x86 and x86-64): - - (sb-alien:with-alien ((buf (array (sb-alien:signed 8) 16)))) - - reported by Stelian Ionescu on sbcl-devel. - 428: TIMER SCHEDULE-STRESS in timer.impure.lisp fails Failure modes vary. Core problem seems to be (?) recursive entry to diff --git a/NEWS b/NEWS index 6c415ca..ff32b75 100644 --- a/NEWS +++ b/NEWS @@ -1,4 +1,9 @@ ;;;; -*- coding: utf-8; -*- +changes in sbcl-1.0.20 relative to 1.0.19: + * bug fix: fixed #427: unused local aliens no longer cause compiler + breakage. (reported by Stelian Ionescu, Andy Hefner and Stanislaw + Halik) + changes in sbcl-1.0.19 relative to 1.0.18: * new feature: user-customizable variable SB-EXT:*MUFFLED-WARNINGS*; warnings that go otherwise unhandled will be muffled if they are diff --git a/src/code/alpha-vm.lisp b/src/code/alpha-vm.lisp index 8373714..71f99b5 100644 --- a/src/code/alpha-vm.lisp +++ b/src/code/alpha-vm.lisp @@ -28,8 +28,7 @@ (unless (zerop (rem offset n-word-bytes)) (error "Unaligned instruction? offset=#x~X." offset)) (sb!sys:without-gcing - (let ((sap (truly-the system-area-pointer - (%primitive code-instructions code)))) + (let ((sap (%primitive code-instructions code))) (ecase kind (:jmp-hint (aver (zerop (ldb (byte 2 0) value))) diff --git a/src/code/hppa-vm.lisp b/src/code/hppa-vm.lisp index dee7b04..f2a3b3a 100644 --- a/src/code/hppa-vm.lisp +++ b/src/code/hppa-vm.lisp @@ -18,8 +18,7 @@ (unless (zerop (rem offset n-word-bytes)) (error "Unaligned instruction? offset=#x~X." offset)) (sb!sys:without-gcing - (let* ((sap (truly-the system-area-pointer - (%primitive sb!kernel::code-instructions code))) + (let* ((sap (%primitive sb!kernel::code-instructions code)) (inst (sap-ref-32 sap offset))) (setf (sap-ref-32 sap offset) (ecase kind diff --git a/src/code/mips-vm.lisp b/src/code/mips-vm.lisp index 936201d..4b077a0 100644 --- a/src/code/mips-vm.lisp +++ b/src/code/mips-vm.lisp @@ -26,8 +26,7 @@ (unless (zerop (rem offset n-word-bytes)) (error "Unaligned instruction? offset=#x~X." offset)) (sb!sys:without-gcing - (let ((sap (truly-the system-area-pointer - (%primitive sb!c::code-instructions code)))) + (let ((sap (%primitive sb!c::code-instructions code))) (ecase kind (:jump (aver (zerop (ash value -28))) diff --git a/src/code/ppc-vm.lisp b/src/code/ppc-vm.lisp index 52cfe55..1a876d6 100644 --- a/src/code/ppc-vm.lisp +++ b/src/code/ppc-vm.lisp @@ -42,8 +42,7 @@ (unless (zerop (rem offset n-word-bytes)) (error "Unaligned instruction? offset=#x~X." offset)) (sb!sys:without-gcing - (let ((sap (truly-the system-area-pointer - (%primitive sb!kernel::code-instructions code)))) + (let ((sap (%primitive sb!kernel::code-instructions code))) (ecase kind (:b (error "Can't deal with CALL fixups, yet.")) diff --git a/src/code/room.lisp b/src/code/room.lisp index 87770c1..bb91438 100644 --- a/src/code/room.lisp +++ b/src/code/room.lisp @@ -518,8 +518,7 @@ (lambda (obj type size) (when (eql type code-header-widetag) (let ((words (truly-the fixnum (%code-code-size obj))) - (sap (truly-the system-area-pointer - (%primitive code-instructions obj))) + (sap (%primitive code-instructions obj)) (size size)) (declare (fixnum size)) (incf total-bytes size) diff --git a/src/code/sparc-vm.lisp b/src/code/sparc-vm.lisp index 55c655c..129c835 100644 --- a/src/code/sparc-vm.lisp +++ b/src/code/sparc-vm.lisp @@ -28,8 +28,7 @@ (unless (zerop (rem offset n-word-bytes)) (error "Unaligned instruction? offset=#x~X." offset)) (sb!sys:without-gcing - (let ((sap (truly-the system-area-pointer - (%primitive sb!kernel::code-instructions code)))) + (let ((sap (%primitive sb!kernel::code-instructions code))) (ecase kind (:call (error "Can't deal with CALL fixups, yet.")) diff --git a/src/compiler/aliencomp.lisp b/src/compiler/aliencomp.lisp index bc5b11a..eff524d 100644 --- a/src/compiler/aliencomp.lisp +++ b/src/compiler/aliencomp.lisp @@ -349,28 +349,26 @@ (/noshow (local-alien-info-force-to-memory-p info)) (/noshow alien-type (unparse-alien-type alien-type) (alien-type-bits alien-type)) (if (local-alien-info-force-to-memory-p info) - #!+(or x86 x86-64) - `(truly-the system-area-pointer - (%primitive alloc-alien-stack-space - ,(ceiling (alien-type-bits alien-type) - sb!vm:n-byte-bits))) - #!-(or x86 x86-64) - `(truly-the system-area-pointer - (%primitive alloc-number-stack-space - ,(ceiling (alien-type-bits alien-type) - sb!vm:n-byte-bits))) - (let* ((alien-rep-type-spec (compute-alien-rep-type alien-type)) - (alien-rep-type (specifier-type alien-rep-type-spec))) - (cond ((csubtypep (specifier-type 'system-area-pointer) - alien-rep-type) - '(int-sap 0)) - ((ctypep 0 alien-rep-type) 0) - ((ctypep 0.0f0 alien-rep-type) 0.0f0) - ((ctypep 0.0d0 alien-rep-type) 0.0d0) - (t - (compiler-error - "Aliens of type ~S cannot be represented immediately." - (unparse-alien-type alien-type)))))))) + #!+(or x86 x86-64) + `(%primitive alloc-alien-stack-space + ,(ceiling (alien-type-bits alien-type) + sb!vm:n-byte-bits)) + #!-(or x86 x86-64) + `(%primitive alloc-number-stack-space + ,(ceiling (alien-type-bits alien-type) + sb!vm:n-byte-bits)) + (let* ((alien-rep-type-spec (compute-alien-rep-type alien-type)) + (alien-rep-type (specifier-type alien-rep-type-spec))) + (cond ((csubtypep (specifier-type 'system-area-pointer) + alien-rep-type) + '(int-sap 0)) + ((ctypep 0 alien-rep-type) 0) + ((ctypep 0.0f0 alien-rep-type) 0.0f0) + ((ctypep 0.0d0 alien-rep-type) 0.0d0) + (t + (compiler-error + "Aliens of type ~S cannot be represented immediately." + (unparse-alien-type alien-type)))))))) (deftransform note-local-alien-type ((info var) * * :important t) ;; FIXME: This test and error occur about a zillion times. They diff --git a/src/compiler/ir2tran.lisp b/src/compiler/ir2tran.lisp index e98d839..28a74da 100644 --- a/src/compiler/ir2tran.lisp +++ b/src/compiler/ir2tran.lisp @@ -595,61 +595,49 @@ (ir2-convert-conditional node block (template-or-lose 'if-eq) test-ref () node t))) -;;; Return a list of primitive-types that we can pass to -;;; LVAR-RESULT-TNS describing the result types we want for a -;;; template call. We duplicate here the determination of output type -;;; that was done in initially selecting the template, so we know that -;;; the types we find are allowed by the template output type -;;; restrictions. -(defun find-template-result-types (call template rtypes) - (declare (type combination call) - (type template template) (list rtypes)) - (declare (ignore template)) - (let* ((dtype (node-derived-type call)) - (type dtype) - (types (mapcar #'primitive-type - (if (values-type-p type) - (append (values-type-required type) - (values-type-optional type)) - (list type))))) - (let ((nvals (length rtypes)) - (ntypes (length types))) - (cond ((< ntypes nvals) - (append types - (make-list (- nvals ntypes) - :initial-element *backend-t-primitive-type*))) - ((> ntypes nvals) - (subseq types 0 nvals)) - (t - types))))) - -;;; Return a list of TNs usable in a CALL to TEMPLATE delivering -;;; values to LVAR. As an efficiency hack, we pick off the common case -;;; where the LVAR is fixed values and has locations that satisfy the -;;; result restrictions. This can fail when there is a type check or a -;;; values count mismatch. -(defun make-template-result-tns (call lvar template rtypes) +;;; Return a list of primitive-types that we can pass to LVAR-RESULT-TNS +;;; describing the result types we want for a template call. We are really +;;; only interested in the number of results required: in normal case +;;; TEMPLATE-RESULTS-OK has already checked them. +(defun find-template-result-types (call rtypes) + (let* ((type (node-derived-type call)) + (types + (mapcar #'primitive-type + (if (values-type-p type) + (append (args-type-required type) + (args-type-optional type)) + (list type)))) + (primitive-t *backend-t-primitive-type*)) + (loop for rtype in rtypes + for type = (or (pop types) primitive-t) + collect type))) + +;;; Return a list of TNs usable in a CALL to TEMPLATE delivering values to +;;; LVAR. As an efficiency hack, we pick off the common case where the LVAR is +;;; fixed values and has locations that satisfy the result restrictions. This +;;; can fail when there is a type check or a values count mismatch. +(defun make-template-result-tns (call lvar rtypes) (declare (type combination call) (type (or lvar null) lvar) - (type template template) (list rtypes)) + (list rtypes)) (let ((2lvar (when lvar (lvar-info lvar)))) (if (and 2lvar (eq (ir2-lvar-kind 2lvar) :fixed)) (let ((locs (ir2-lvar-locs 2lvar))) (if (and (= (length rtypes) (length locs)) (do ((loc locs (cdr loc)) - (rtype rtypes (cdr rtype))) + (rtypes rtypes (cdr rtypes))) ((null loc) t) (unless (operand-restriction-ok - (car rtype) + (car rtypes) (tn-primitive-type (car loc)) :t-ok nil) (return nil)))) locs (lvar-result-tns lvar - (find-template-result-types call template rtypes)))) + (find-template-result-types call rtypes)))) (lvar-result-tns lvar - (find-template-result-types call template rtypes))))) + (find-template-result-types call rtypes))))) ;;; Get the operands into TNs, make TN-REFs for them, and then call ;;; the template emit function. @@ -664,7 +652,7 @@ (if (eq rtypes :conditional) (ir2-convert-conditional call block template args info-args (lvar-dest lvar) nil) - (let* ((results (make-template-result-tns call lvar template rtypes)) + (let* ((results (make-template-result-tns call lvar rtypes)) (r-refs (reference-tn-list results t))) (aver (= (length info-args) (template-info-arg-count template))) @@ -688,7 +676,7 @@ (info (lvar-value info)) (lvar (node-lvar call)) (rtypes (template-result-types template)) - (results (make-template-result-tns call lvar template rtypes)) + (results (make-template-result-tns call lvar rtypes)) (r-refs (reference-tn-list results t))) (multiple-value-bind (args info-args) (reference-args call block (cddr (combination-args call)) template) @@ -702,6 +690,12 @@ (move-lvar-result call block results lvar))) (values)) + +(defoptimizer (%%primitive derive-type) ((template info &rest args)) + (let ((type (template-type (lvar-value template)))) + (if (fun-type-p type) + (fun-type-returns type) + *wild-type*))) ;;;; local call diff --git a/tests/alien.impure.lisp b/tests/alien.impure.lisp index d1ee3e3..8eda29a 100644 --- a/tests/alien.impure.lisp +++ b/tests/alien.impure.lisp @@ -203,4 +203,11 @@ (error () :ok))))) +;;; Unused local alien caused a compiler error +(with-test (:name unused-local-alien) + (let ((fun `(lambda () + (sb-alien:with-alien ((alien1923 (array (sb-alien:unsigned 8) 72))) + (values))))) + (assert (not (funcall (compile nil fun)))))) + ;;; success diff --git a/version.lisp-expr b/version.lisp-expr index aa1343c..d60b9a4 100644 --- a/version.lisp-expr +++ b/version.lisp-expr @@ -17,4 +17,4 @@ ;;; checkins which aren't released. (And occasionally for internal ;;; versions, especially for internal versions off the main CVS ;;; branch, it gets hairier, e.g. "0.pre7.14.flaky4.13".) -"1.0.19" +"1.0.19.1"